KIDS Distribution saved on Dec 04, 2017@08:57:58 VistA Imaging V3.0 - Patch 180 **KIDS**:MAG*3.0*180^ **INSTALL NAME** MAG*3.0*180 "BLD",8361,0) MAG*3.0*180^IMAGING^0^3171204^y "BLD",8361,1,0) ^^15^15^3171127^ "BLD",8361,1,1,0) VistA Imaging V3.0 - P180 "BLD",8361,1,2,0) "BLD",8361,1,3,0) Routines: "BLD",8361,1,4,0) "BLD",8361,1,5,0) MAGDHOW1 "BLD",8361,1,6,0) MAGDHOW3 "BLD",8361,1,7,0) MAGDRPC3 "BLD",8361,1,8,0) MAGDRPC4 "BLD",8361,1,9,0) MAGDRPC9 "BLD",8361,1,10,0) "BLD",8361,1,11,0) "BLD",8361,1,12,0) "BLD",8361,1,13,0) "BLD",8361,1,14,0) Please note that routine MAGIP180 is deleted after the KIDS build is "BLD",8361,1,15,0) installed "BLD",8361,4,0) ^9.64PA^^ "BLD",8361,6.3) 16 "BLD",8361,"ABNS",0) ^9.66A^^ "BLD",8361,"ABPKG") n^n^G.IMAGING DEVELOPMENT TEAM@domain.ext "BLD",8361,"INID") n^y^n "BLD",8361,"INIT") POS^MAGIP180 "BLD",8361,"KRN",0) ^9.67PA^779.2^20 "BLD",8361,"KRN",.4,0) .4 "BLD",8361,"KRN",.401,0) .401 "BLD",8361,"KRN",.402,0) .402 "BLD",8361,"KRN",.403,0) .403 "BLD",8361,"KRN",.5,0) .5 "BLD",8361,"KRN",.84,0) .84 "BLD",8361,"KRN",3.6,0) 3.6 "BLD",8361,"KRN",3.8,0) 3.8 "BLD",8361,"KRN",9.2,0) 9.2 "BLD",8361,"KRN",9.8,0) 9.8 "BLD",8361,"KRN",9.8,"NM",0) ^9.68A^5^5 "BLD",8361,"KRN",9.8,"NM",1,0) MAGDRPC3^^0^B66319666 "BLD",8361,"KRN",9.8,"NM",2,0) MAGDRPC4^^0^B106996677 "BLD",8361,"KRN",9.8,"NM",3,0) MAGDRPC9^^0^B94046476 "BLD",8361,"KRN",9.8,"NM",4,0) MAGDHOW1^^0^B28635180 "BLD",8361,"KRN",9.8,"NM",5,0) MAGDHOW3^^0^B29400987 "BLD",8361,"KRN",9.8,"NM","B","MAGDHOW1",4) "BLD",8361,"KRN",9.8,"NM","B","MAGDHOW3",5) "BLD",8361,"KRN",9.8,"NM","B","MAGDRPC3",1) "BLD",8361,"KRN",9.8,"NM","B","MAGDRPC4",2) "BLD",8361,"KRN",9.8,"NM","B","MAGDRPC9",3) "BLD",8361,"KRN",19,0) 19 "BLD",8361,"KRN",19.1,0) 19.1 "BLD",8361,"KRN",101,0) 101 "BLD",8361,"KRN",409.61,0) 409.61 "BLD",8361,"KRN",771,0) 771 "BLD",8361,"KRN",779.2,0) 779.2 "BLD",8361,"KRN",870,0) 870 "BLD",8361,"KRN",8989.51,0) 8989.51 "BLD",8361,"KRN",8989.52,0) 8989.52 "BLD",8361,"KRN",8994,0) 8994 "BLD",8361,"KRN","B",.4,.4) "BLD",8361,"KRN","B",.401,.401) "BLD",8361,"KRN","B",.402,.402) "BLD",8361,"KRN","B",.403,.403) "BLD",8361,"KRN","B",.5,.5) "BLD",8361,"KRN","B",.84,.84) "BLD",8361,"KRN","B",3.6,3.6) "BLD",8361,"KRN","B",3.8,3.8) "BLD",8361,"KRN","B",9.2,9.2) "BLD",8361,"KRN","B",9.8,9.8) "BLD",8361,"KRN","B",19,19) "BLD",8361,"KRN","B",19.1,19.1) "BLD",8361,"KRN","B",101,101) "BLD",8361,"KRN","B",409.61,409.61) "BLD",8361,"KRN","B",771,771) "BLD",8361,"KRN","B",779.2,779.2) "BLD",8361,"KRN","B",870,870) "BLD",8361,"KRN","B",8989.51,8989.51) "BLD",8361,"KRN","B",8989.52,8989.52) "BLD",8361,"KRN","B",8994,8994) "BLD",8361,"QDEF") ^^^^NO^^^^NO^^NO "BLD",8361,"QUES",0) ^9.62^^ "BLD",8361,"REQB",0) ^9.611^1^1 "BLD",8361,"REQB",1,0) MAG*3.0*166^2 "BLD",8361,"REQB","B","MAG*3.0*166",1) "INIT") POS^MAGIP180 "MBREQ") 0 "PKG",454,-1) 1^1 "PKG",454,0) IMAGING^MAG^Imaging-V1 to release "PKG",454,20,0) ^9.402P^^ "PKG",454,22,0) ^9.49I^1^1 "PKG",454,22,1,0) 3.0^3020319^3020517^126 "PKG",454,22,1,"PAH",1,0) 180^3171204^126 "PKG",454,22,1,"PAH",1,1,0) ^^15^15^3171204 "PKG",454,22,1,"PAH",1,1,1,0) VistA Imaging V3.0 - P180 "PKG",454,22,1,"PAH",1,1,2,0) "PKG",454,22,1,"PAH",1,1,3,0) Routines: "PKG",454,22,1,"PAH",1,1,4,0) "PKG",454,22,1,"PAH",1,1,5,0) MAGDHOW1 "PKG",454,22,1,"PAH",1,1,6,0) MAGDHOW3 "PKG",454,22,1,"PAH",1,1,7,0) MAGDRPC3 "PKG",454,22,1,"PAH",1,1,8,0) MAGDRPC4 "PKG",454,22,1,"PAH",1,1,9,0) MAGDRPC9 "PKG",454,22,1,"PAH",1,1,10,0) "PKG",454,22,1,"PAH",1,1,11,0) "PKG",454,22,1,"PAH",1,1,12,0) "PKG",454,22,1,"PAH",1,1,13,0) "PKG",454,22,1,"PAH",1,1,14,0) Please note that routine MAGIP180 is deleted after the KIDS build is "PKG",454,22,1,"PAH",1,1,15,0) installed "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 6 "RTN","MAGDHOW1") 0^4^B28635180 "RTN","MAGDHOW1",1,0) MAGDHOW1 ;WOIFO/PMK/DAC - Capture Consult/Procedure Request data ; Aug 28, 2017 "RTN","MAGDHOW1",2,0) ;;3.0;IMAGING;**138,174,180**;Mar 19, 2002;Build 16 "RTN","MAGDHOW1",3,0) ;; Per VHA Directive 2004-038, this routine should not be modified. "RTN","MAGDHOW1",4,0) ;; +---------------------------------------------------------------+ "RTN","MAGDHOW1",5,0) ;; | Property of the US Government. | "RTN","MAGDHOW1",6,0) ;; | No permission to copy or redistribute this software is given. | "RTN","MAGDHOW1",7,0) ;; | Use of unreleased versions of this software requires the user | "RTN","MAGDHOW1",8,0) ;; | to execute a written test agreement with the VistA Imaging | "RTN","MAGDHOW1",9,0) ;; | Development Office of the Department of Veterans Affairs, | "RTN","MAGDHOW1",10,0) ;; | telephone (301) 734-0100. | "RTN","MAGDHOW1",11,0) ;; | The Food and Drug Administration classifies this software as | "RTN","MAGDHOW1",12,0) ;; | a medical device. As such, it may not be changed in any way. | "RTN","MAGDHOW1",13,0) ;; | Modifications to this software may result in an adulterated | "RTN","MAGDHOW1",14,0) ;; | medical device under 21CFR820, the use of which is considered | "RTN","MAGDHOW1",15,0) ;; | to be a violation of US Federal Statutes. | "RTN","MAGDHOW1",16,0) ;; +---------------------------------------------------------------+ "RTN","MAGDHOW1",17,0) ;; "RTN","MAGDHOW1",18,0) MSGSETUP(GMRCIEN,SERVICE,ORC1,ORC5,APTSCHED) ; called by ^MAGDHOWC and ^MAGDHOWS "RTN","MAGDHOW1",19,0) ; setup to send a message, if required "RTN","MAGDHOW1",20,0) N CONSULT,CPTIEN,DATETIME,DIVISION,FMDATE,FMDATETM "RTN","MAGDHOW1",21,0) N HL7SUBLIST,I,ITYPCODE,ITYPNAME,MSGTYPE,OBXSEGNO "RTN","MAGDHOW1",22,0) N ORCTRL,ORSTATUS,ORIGSERV,PARMS,SEGMENT,SENDIT,X,Y,Z "RTN","MAGDHOW1",23,0) ; "RTN","MAGDHOW1",24,0) S FMDATETM=$$NOW^XLFDT(),FMDATE=FMDATETM\1 "RTN","MAGDHOW1",25,0) S MSGTYPE="ORM" ; HL7 message type for orders "RTN","MAGDHOW1",26,0) ; "RTN","MAGDHOW1",27,0) ; decide if service is one that requires HL7->DICOM gateway and PACS "RTN","MAGDHOW1",28,0) ; "RTN","MAGDHOW1",29,0) S SENDIT=$$SERVICE(SERVICE,GMRCIEN,.DIVISION,.ITYPNAME,.ITYPCODE,.CPTIEN,.HL7SUBLIST) "RTN","MAGDHOW1",30,0) ; "RTN","MAGDHOW1",31,0) I SENDIT D ; send this transaction via HL7 to DICOM gateway and PACS "RTN","MAGDHOW1",32,0) . ; check for an "OK" order control value which indicates a new order "RTN","MAGDHOW1",33,0) . I ORC1="OK" D "RTN","MAGDHOW1",34,0) . . S ORCTRL="NW" ; order control "RTN","MAGDHOW1",35,0) . . S ORSTATUS="IP" ; order status "RTN","MAGDHOW1",36,0) . . Q "RTN","MAGDHOW1",37,0) . ; "RTN","MAGDHOW1",38,0) . ; check for a cancelled or discontinued request "RTN","MAGDHOW1",39,0) . E I " CA CR DR OC OD "[(" "_ORC1_" ") D "RTN","MAGDHOW1",40,0) . . K FILLER2 ; P174 DAC - remove any preset status like GMRC-SCHEDULED set in CHECKAPT^MAGDHOWC "RTN","MAGDHOW1",41,0) . . S ORCTRL="CA" ; order control "RTN","MAGDHOW1",42,0) . . S ORSTATUS="CA" ; order status "RTN","MAGDHOW1",43,0) . . Q "RTN","MAGDHOW1",44,0) . ; "RTN","MAGDHOW1",45,0) . ; check for scheduled request (set in ^MAGDHOWS) "RTN","MAGDHOW1",46,0) . E I ORC1="XO",ORC5="SC" D "RTN","MAGDHOW1",47,0) . . S ORCTRL="XO" ; order control "RTN","MAGDHOW1",48,0) . . S ORSTATUS="SC" ; order status "RTN","MAGDHOW1",49,0) . . Q "RTN","MAGDHOW1",50,0) . ; "RTN","MAGDHOW1",51,0) . ; look for a result message "RTN","MAGDHOW1",52,0) . E I ORC1="RE" D ; result "RTN","MAGDHOW1",53,0) . . S MSGTYPE="ORU" ; HL7 message type for results "RTN","MAGDHOW1",54,0) . . ; "RTN","MAGDHOW1",55,0) . . I (ORC5="A")!($$UNSIGNED^MAGDGMRC(GMRCIEN)) D ; P180 DAC - Process unsigned TIU notes "RTN","MAGDHOW1",56,0) . . . S FILLER2="GMRC-NEW UNSIGNED RESULT" "RTN","MAGDHOW1",57,0) . . . S ORCTRL="RE" ; order control "RTN","MAGDHOW1",58,0) . . . S ORSTATUS="A" ; order status "RTN","MAGDHOW1",59,0) . . . Q "RTN","MAGDHOW1",60,0) . . E D ; new signed TIU note "RTN","MAGDHOW1",61,0) . . . K FILLER2 ; P174 DAC - remove any preset status like GMRC-SCHEDULED set in CHECKAPT^MAGDHOWC "RTN","MAGDHOW1",62,0) . . . S ORCTRL="RE" ; order control "RTN","MAGDHOW1",63,0) . . . S ORSTATUS="CM" ; order status "RTN","MAGDHOW1",64,0) . . . Q "RTN","MAGDHOW1",65,0) . . Q "RTN","MAGDHOW1",66,0) . ; "RTN","MAGDHOW1",67,0) . E D ; default "RTN","MAGDHOW1",68,0) . . S ORCTRL="SC" ; order control "RTN","MAGDHOW1",69,0) . . S ORSTATUS="IP" ; order status "RTN","MAGDHOW1",70,0) . . Q "RTN","MAGDHOW1",71,0) . D MESSAGE^MAGDHOW2(SERVICE) "RTN","MAGDHOW1",72,0) . Q "RTN","MAGDHOW1",73,0) ; "RTN","MAGDHOW1",74,0) I ORC1="RE" D ; do this for all consult results "RTN","MAGDHOW1",75,0) . ; link any outstanding DICOM images to the new TIU note "RTN","MAGDHOW1",76,0) . S I=$$NEWTIU^MAGDHOW0(GMRCIEN) "RTN","MAGDHOW1",77,0) . Q "RTN","MAGDHOW1",78,0) ; "RTN","MAGDHOW1",79,0) Q "RTN","MAGDHOW1",80,0) ; "RTN","MAGDHOW1",81,0) SERVICE(SERVICE,GMRCIEN,DIVISION,ITYPNAME,ITYPCODE,CPTIEN,HL7SUBLIST) ; "RTN","MAGDHOW1",82,0) ; check if the service is in the DICOM Clinical Service dictionary, and "RTN","MAGDHOW1",83,0) ; if so, then get all of the attributes "RTN","MAGDHOW1",84,0) N MWLCONFIG,SENDIT,X,Y,Z "RTN","MAGDHOW1",85,0) S (DIVISION,ITYPNAME,ITYPCODE,CPTIEN,HL7SUBLIST,SENDIT)=0 "RTN","MAGDHOW1",86,0) I SERVICE D ; ignore SERVICE if it is null "RTN","MAGDHOW1",87,0) . S MWLCONFIG=$$MWLFIND(SERVICE,GMRCIEN) "RTN","MAGDHOW1",88,0) . S DIVISION="" "RTN","MAGDHOW1",89,0) . I MWLCONFIG D ; send order "RTN","MAGDHOW1",90,0) . . S X=$G(^MAG(2006.5831,MWLCONFIG,0)) "RTN","MAGDHOW1",91,0) . . S DIVISION=$P(X,"^",5),CPTIEN=$P(X,"^",6),HL7SUBLIST=$P(X,"^",7) "RTN","MAGDHOW1",92,0) . . I HL7SUBLIST,$$GET1^DIQ(779.4,HL7SUBLIST,.01)="" S HL7SUBLIST=0 ; absent "RTN","MAGDHOW1",93,0) . . I 'HL7SUBLIST D ; lookup default HL7 subscription list "RTN","MAGDHOW1",94,0) . . . N DIC,DO,X,Y "RTN","MAGDHOW1",95,0) . . . S DIC=779.4,DIC(0)="BX",X="MAGD DEFAULT" D ^DIC "RTN","MAGDHOW1",96,0) . . . S HL7SUBLIST=$P(Y,"^",1) ; Y should equal "^MAGD DEFAULT" "RTN","MAGDHOW1",97,0) . . . Q "RTN","MAGDHOW1",98,0) . . ; get specialty index and procedure index (if available, otherwise, use 0) "RTN","MAGDHOW1",99,0) . . S Y=$P(X,"^",3) "RTN","MAGDHOW1",100,0) . . S ITYPNAME=$P(^MAG(2005.84,Y,0),"^",1) "RTN","MAGDHOW1",101,0) . . S ITYPCODE=$P(^MAG(2005.84,Y,2),"^",1) "RTN","MAGDHOW1",102,0) . . S Z=$P(X,"^",4) "RTN","MAGDHOW1",103,0) . . I Z D ; get procedure name and code "RTN","MAGDHOW1",104,0) . . . S ITYPNAME=ITYPNAME_" -- "_$P(^MAG(2005.85,Z,0),"^",1) "RTN","MAGDHOW1",105,0) . . . S ITYPCODE=ITYPCODE_"/"_$P(^MAG(2005.85,Z,2),"^",1) "RTN","MAGDHOW1",106,0) . . . Q "RTN","MAGDHOW1",107,0) . . S SENDIT=1 "RTN","MAGDHOW1",108,0) . . Q "RTN","MAGDHOW1",109,0) . Q "RTN","MAGDHOW1",110,0) Q SENDIT "RTN","MAGDHOW1",111,0) ; "RTN","MAGDHOW1",112,0) MWLFIND(SERVICE,GMRCIEN) ; lookup 2006.5831 entry by service and procedure "RTN","MAGDHOW1",113,0) ; ordering a procedure and the 2006.5831 procedure entry are optional "RTN","MAGDHOW1",114,0) N PROCEDURE "RTN","MAGDHOW1",115,0) S PROCEDURE=+$$GET1^DIQ(123,GMRCIEN,4,"I") "RTN","MAGDHOW1",116,0) Q $$IREQUEST(SERVICE,PROCEDURE) ; pointer to modality worklist dictionary file #2006.5831 "RTN","MAGDHOW1",117,0) ; "RTN","MAGDHOW1",118,0) IREQUEST(SERVICE,PROCEDURE) ; return the IEN of the consult or procedure for the request service "RTN","MAGDHOW1",119,0) N IEN,LIST "RTN","MAGDHOW1",120,0) ; "RTN","MAGDHOW1",121,0) S SERVICE=$G(SERVICE) I 'SERVICE Q 0 "RTN","MAGDHOW1",122,0) ; "RTN","MAGDHOW1",123,0) ; if this is a lookup for a procedure, just return the "C" cross reference "RTN","MAGDHOW1",124,0) S PROCEDURE=$G(PROCEDURE) "RTN","MAGDHOW1",125,0) I PROCEDURE Q $O(^MAG(2006.5831,"C",SERVICE,PROCEDURE,"")) "RTN","MAGDHOW1",126,0) ; "RTN","MAGDHOW1",127,0) ; use the "B" cross reference to make a list of all IENs for the request service "RTN","MAGDHOW1",128,0) S IEN="" F S IEN=$O(^MAG(2006.5831,"B",SERVICE,IEN)) Q:IEN="" S LIST(IEN)="" "RTN","MAGDHOW1",129,0) ; "RTN","MAGDHOW1",130,0) ; use the "C" cross reference to delete the IENs for the procedures "RTN","MAGDHOW1",131,0) S PROCEDURE="" F S PROCEDURE=$O(^MAG(2006.5831,"C",SERVICE,PROCEDURE)) Q:PROCEDURE="" D "RTN","MAGDHOW1",132,0) . S IEN=$O(^MAG(2006.5831,"C",SERVICE,PROCEDURE,"")) "RTN","MAGDHOW1",133,0) . K LIST(IEN) ; remove the procedures from the list "RTN","MAGDHOW1",134,0) . Q "RTN","MAGDHOW1",135,0) ; "RTN","MAGDHOW1",136,0) ; return what is left in the list, which should be the consult, if there is one "RTN","MAGDHOW1",137,0) Q $O(LIST("")) "RTN","MAGDHOW3") 0^5^B29400987 "RTN","MAGDHOW3",1,0) MAGDHOW3 ;WOIFO/PMK,DWM,DAC - Capture Consult/GMRC data ; 11 Oct 2017 11:41 AM "RTN","MAGDHOW3",2,0) ;;3.0;IMAGING;**138,180**;Mar 19, 2002;Build 16 "RTN","MAGDHOW3",3,0) ;; Per VHA Directive 2004-038, this routine should not be modified. "RTN","MAGDHOW3",4,0) ;; +---------------------------------------------------------------+ "RTN","MAGDHOW3",5,0) ;; | Property of the US Government. | "RTN","MAGDHOW3",6,0) ;; | No permission to copy or redistribute this software is given. | "RTN","MAGDHOW3",7,0) ;; | Use of unreleased versions of this software requires the user | "RTN","MAGDHOW3",8,0) ;; | to execute a written test agreement with the VistA Imaging | "RTN","MAGDHOW3",9,0) ;; | Development Office of the Department of Veterans Affairs, | "RTN","MAGDHOW3",10,0) ;; | telephone (301) 734-0100. | "RTN","MAGDHOW3",11,0) ;; | The Food and Drug Administration classifies this software as | "RTN","MAGDHOW3",12,0) ;; | a medical device. As such, it may not be changed in any way. | "RTN","MAGDHOW3",13,0) ;; | Modifications to this software may result in an adulterated | "RTN","MAGDHOW3",14,0) ;; | medical device under 21CFR820, the use of which is considered | "RTN","MAGDHOW3",15,0) ;; | to be a violation of US Federal Statutes. | "RTN","MAGDHOW3",16,0) ;; +---------------------------------------------------------------+ "RTN","MAGDHOW3",17,0) ;; "RTN","MAGDHOW3",18,0) ; "RTN","MAGDHOW3",19,0) ; "RTN","MAGDHOW3",20,0) ORC(HLMSTATE,GMRCIEN,SAVEORCSEG) ; build the ORC segment (see ORC^GMRCHL7) "RTN","MAGDHOW3",21,0) N ACNUMB,ERROR,ORCSEG,ORDERENTERER,ORDERNUMBER,ORDERPLACER,PRIORITY,SUCCESS,X "RTN","MAGDHOW3",22,0) D SET^HLOAPI(.ORCSEG,"ORC",0) "RTN","MAGDHOW3",23,0) D SET^HLOAPI(.ORCSEG,ORCTRL,1) ; ORC-1 order control "RTN","MAGDHOW3",24,0) S ORDERNUMBER=$$GET1^DIQ(123,GMRCIEN,.03,"I") ; oe/rr file number "RTN","MAGDHOW3",25,0) D SET^HLOAPI(.ORCSEG,$$STATNUMB^MAGDFCNV()_"-OR-"_ORDERNUMBER,2) ; ORC-2 placer order number "RTN","MAGDHOW3",26,0) S ACNUMB=$$GMRCACN^MAGDFCNV(GMRCIEN) "RTN","MAGDHOW3",27,0) D SET^HLOAPI(.ORCSEG,ACNUMB,3) ; ORC-3 filler order number "RTN","MAGDHOW3",28,0) ; "RTN","MAGDHOW3",29,0) D SET^HLOAPI(.ORCSEG,ORSTATUS,5) ; ORC-5 order status "RTN","MAGDHOW3",30,0) ; ORC-6 not used "RTN","MAGDHOW3",31,0) ; "RTN","MAGDHOW3",32,0) ; store date and time of scheduled appointment for order messages, not results "RTN","MAGDHOW3",33,0) I MSGTYPE="ORM",$D(APTSCHED("FM DATETIME")) D "RTN","MAGDHOW3",34,0) . D SET^HLOAPI(.ORCSEG,$$FMTHL7^XLFDT(APTSCHED("FM DATETIME")),7,4) ; ORC-7 start date/time "RTN","MAGDHOW3",35,0) . Q "RTN","MAGDHOW3",36,0) S PRIORITY=$$GET1^DIQ(123,GMRCIEN,5),PRIORITY=$P(PRIORITY," - ",2) ; urgency "RTN","MAGDHOW3",37,0) S PRIORITY=$S(PRIORITY="EMERGENCY":"STAT",PRIORITY="NOW":"STAT",PRIORITY="OUTPATIENT":"ROUTINE",1:PRIORITY) "RTN","MAGDHOW3",38,0) I PRIORITY'="" D ; convert to HL7 priority "RTN","MAGDHOW3",39,0) . N URGENCY "RTN","MAGDHOW3",40,0) . S URGENCY=$$FIND1^DIC(101.42,,"B",PRIORITY) "RTN","MAGDHOW3",41,0) . S PRIORITY=$S(URGENCY:$$GET1^DIQ(101.42,URGENCY,2,"E"),1:"") "RTN","MAGDHOW3",42,0) . Q "RTN","MAGDHOW3",43,0) D SET^HLOAPI(.ORCSEG,PRIORITY,7,6) ; ORC-7 priority "RTN","MAGDHOW3",44,0) ; ORC-8 not used "RTN","MAGDHOW3",45,0) D SET^HLOAPI(.ORCSEG,$$FMTHL7^XLFDT(FMDATETM),9) ; ORC-9 date/time of transaction "RTN","MAGDHOW3",46,0) S ORDERENTERER=$$GET1^DIQ(100,ORDERNUMBER,3,"I") ; Order file - who entered "RTN","MAGDHOW3",47,0) D NAME^MAGDHOW3(ORDERENTERER,10,.ORCSEG) ; ORC-10 entered by "RTN","MAGDHOW3",48,0) ; ORC-11 not used "RTN","MAGDHOW3",49,0) S ORDERPLACER=$$GET1^DIQ(123,GMRCIEN,10,"I") ; sending provider "RTN","MAGDHOW3",50,0) D NAME^MAGDHOW3(ORDERPLACER,12,.ORCSEG) ; ORC-12 ordering provider "RTN","MAGDHOW3",51,0) S X=$$GET1^DIQ(200,ORDERENTERER,29) ; service/section "RTN","MAGDHOW3",52,0) D SET^HLOAPI(.ORCSEG,X,13) ; ORC-13 enterer's location "RTN","MAGDHOW3",53,0) D PHONE^MAGDHOW3(ORDERPLACER,14,.ORCSEG) ; ORC-14 call back phone number(s) "RTN","MAGDHOW3",54,0) S X=$$GET1^DIQ(123,GMRCIEN,3,"I") ; date of request "RTN","MAGDHOW3",55,0) D SET^HLOAPI(.ORCSEG,$$FMTHL7^XLFDT(X),15) ; ORC-15 order effective date/time "RTN","MAGDHOW3",56,0) ; ORC-16 not used "RTN","MAGDHOW3",57,0) S X=$$GET1^DIQ(200,ORDERPLACER,29,"I") ; ordering provider's service/section "RTN","MAGDHOW3",58,0) ; entering organization (abbreviation, name, coding system) "RTN","MAGDHOW3",59,0) D SET^HLOAPI(.ORCSEG,$$GET1^DIQ(49,X,1),17,1) "RTN","MAGDHOW3",60,0) D SET^HLOAPI(.ORCSEG,$$GET1^DIQ(49,X,.01),17,2) "RTN","MAGDHOW3",61,0) D SET^HLOAPI(.ORCSEG,"VISTA49",17,3) "RTN","MAGDHOW3",62,0) ; "RTN","MAGDHOW3",63,0) M SAVEORCSEG=ORCSEG ; save some of the ORC fields for the OBR segment "RTN","MAGDHOW3",64,0) S SUCCESS=$$ADDSEG^HLOAPI(.HLMSTATE,.ORCSEG,.ERROR) "RTN","MAGDHOW3",65,0) I 'SUCCESS D "RTN","MAGDHOW3",66,0) . N MSG,SUBJECT,VARIABLES "RTN","MAGDHOW3",67,0) . S SUBJECT="VistA Imaging Clinical Specialty (CPRS) HL7 Generation" "RTN","MAGDHOW3",68,0) . S MSG(1)="An error occurred in ORC^"_$T(+0)_" where the ADDSEG^HLOAPI invocation" "RTN","MAGDHOW3",69,0) . S MSG(2)="for the ORC segment failed. The error message is as follows:" "RTN","MAGDHOW3",70,0) . S MSG(3)=""""_SUCCESS_"""" "RTN","MAGDHOW3",71,0) . S VARIABLES("HLMSTATE")="" "RTN","MAGDHOW3",72,0) . S VARIABLES("ORCSEG")="" "RTN","MAGDHOW3",73,0) . S VARIABLES("ERROR")="" "RTN","MAGDHOW3",74,0) . D ERROR^MAGDHOWA(SUBJECT,.MSG,.VARIABLES) "RTN","MAGDHOW3",75,0) . Q "RTN","MAGDHOW3",76,0) Q "RTN","MAGDHOW3",77,0) ; "RTN","MAGDHOW3",78,0) NAME(IEN,FIELD,ORCSEG) ; return person's name in HL7 format "RTN","MAGDHOW3",79,0) N DGNAME,I,X "RTN","MAGDHOW3",80,0) S DGNAME("FILE")=200,DGNAME("IENS")=IEN,DGNAME("FIELD")=.01 "RTN","MAGDHOW3",81,0) S X=$$HLNAME^XLFNAME(.DGNAME,"","^") "RTN","MAGDHOW3",82,0) D SET^HLOAPI(.ORCSEG,IEN,FIELD,1) "RTN","MAGDHOW3",83,0) F I=1:1:$L(X,"^") D SET^HLOAPI(.ORCSEG,$P(X,"^",I),FIELD,I+1) "RTN","MAGDHOW3",84,0) Q "RTN","MAGDHOW3",85,0) ; "RTN","MAGDHOW3",86,0) PHONE(IEN,FIELD,SEGMENT) ; call back phone number(s) "RTN","MAGDHOW3",87,0) N FNUMBER,EQTYPE,I,MAGOUT,MAGERR,NUMBER,USECODE,X,REP,J,VAIEN "RTN","MAGDHOW3",88,0) S REP=0 ; HL7 repetition "RTN","MAGDHOW3",89,0) F I=1:1 S X=$T(PHONES+I) Q:"END"[$P(X,";;",2) D "RTN","MAGDHOW3",90,0) . S FNUMBER=$P(X,";",4),USECODE=$P(X,";",5),EQTYPE=$P(X,";",6) "RTN","MAGDHOW3",91,0) . S NUMBER=$$GET1^DIQ(200,IEN,FNUMBER) "RTN","MAGDHOW3",92,0) . D PHONE1(.REP,FIELD,.SEGMENT,NUMBER,USECODE,EQTYPE) "RTN","MAGDHOW3",93,0) . Q "RTN","MAGDHOW3",94,0) ; check VISITED FROM subfile (#8910) to get PHONE AT SITE field (#5) "RTN","MAGDHOW3",95,0) ; P180 DAC - New MAGOUT array to sort from earliest to latest VISITED FROM entries "RTN","MAGDHOW3",96,0) S VAIEN=0 "RTN","MAGDHOW3",97,0) F S VAIEN=$O(^VA(200,IEN,8910,VAIEN)) Q:'VAIEN D "RTN","MAGDHOW3",98,0) . S MAGOUT(VAIEN)=$P($G(^VA(200,IEN,8910,VAIEN,0)),U,6) "RTN","MAGDHOW3",99,0) . Q "RTN","MAGDHOW3",100,0) S I="",J="" F S I=$O(MAGOUT(I)) Q:((I="")!(J=3)) D "RTN","MAGDHOW3",101,0) . S NUMBER=MAGOUT(I) "RTN","MAGDHOW3",102,0) . ; P180 DAC - Screen VISITED FROM w/o phone # and only add first 3 phone #s "RTN","MAGDHOW3",103,0) . N X,Y S X=NUMBER X ^%ZOSF("UPPERCASE") Q:((Y="NO PHONE")!(Y="")) "RTN","MAGDHOW3",104,0) . D PHONE1(.REP,FIELD,.SEGMENT,NUMBER,"WPN","PN") "RTN","MAGDHOW3",105,0) . S J=J+1 "RTN","MAGDHOW3",106,0) . Q "RTN","MAGDHOW3",107,0) Q "RTN","MAGDHOW3",108,0) ; "RTN","MAGDHOW3",109,0) PHONE1(REP,FIELD,SEGMENT,NUMBER,USECODE,EQTYPE) ; store phone info "RTN","MAGDHOW3",110,0) I NUMBER'="" D "RTN","MAGDHOW3",111,0) . S REP=REP+1 "RTN","MAGDHOW3",112,0) . D SET^HLOAPI(.SEGMENT,NUMBER,FIELD,1,1,REP) "RTN","MAGDHOW3",113,0) . D SET^HLOAPI(.SEGMENT,USECODE,FIELD,2,1,REP) "RTN","MAGDHOW3",114,0) . D SET^HLOAPI(.SEGMENT,EQTYPE,FIELD,3,1,REP) "RTN","MAGDHOW3",115,0) . Q "RTN","MAGDHOW3",116,0) Q "RTN","MAGDHOW3",117,0) ; "RTN","MAGDHOW3",118,0) PHONES ;; field name ; field number ; HL7 Use Code ; HL7 Equipment Type "RTN","MAGDHOW3",119,0) ;;PHONE (HOME);.131;PRN;PH "RTN","MAGDHOW3",120,0) ;;OFFICE PHONE;.132;WPN;PH "RTN","MAGDHOW3",121,0) ;;PHONE #3;.133;WPN;PN "RTN","MAGDHOW3",122,0) ;;PHONE #4;.134;WPN;PN "RTN","MAGDHOW3",123,0) ;;COMMERCIAL PHONE;.135;WPN;PN "RTN","MAGDHOW3",124,0) ;;FAX NUMBER;.136;WPN;FX "RTN","MAGDHOW3",125,0) ;;VOICE PAGER;.137;WPN;BP "RTN","MAGDHOW3",126,0) ;;DIGITAL PAGER;.138;BPM;BP "RTN","MAGDHOW3",127,0) ;;END "RTN","MAGDHOW3",128,0) ; "RTN","MAGDRPC3") 0^1^B66319666 "RTN","MAGDRPC3",1,0) MAGDRPC3 ;WOIFO/EdM,SAF,DAC - Imaging RPCs ; 24 Oct 2017 4:40 PM "RTN","MAGDRPC3",2,0) ;;3.0;IMAGING;**11,30,51,50,85,54,49,123,138,180**;Mar 19, 2002;Build 16 "RTN","MAGDRPC3",3,0) ;; Per VHA Directive 2004-038, this routine should not be modified. "RTN","MAGDRPC3",4,0) ;; +---------------------------------------------------------------+ "RTN","MAGDRPC3",5,0) ;; | Property of the US Government. | "RTN","MAGDRPC3",6,0) ;; | No permission to copy or redistribute this software is given. | "RTN","MAGDRPC3",7,0) ;; | Use of unreleased versions of this software requires the user | "RTN","MAGDRPC3",8,0) ;; | to execute a written test agreement with the VistA Imaging | "RTN","MAGDRPC3",9,0) ;; | Development Office of the Department of Veterans Affairs, | "RTN","MAGDRPC3",10,0) ;; | telephone (301) 734-0100. | "RTN","MAGDRPC3",11,0) ;; | The Food and Drug Administration classifies this software as | "RTN","MAGDRPC3",12,0) ;; | a medical device. As such, it may not be changed in any way. | "RTN","MAGDRPC3",13,0) ;; | Modifications to this software may result in an adulterated | "RTN","MAGDRPC3",14,0) ;; | medical device under 21CFR820, the use of which is considered | "RTN","MAGDRPC3",15,0) ;; | to be a violation of US Federal Statutes. | "RTN","MAGDRPC3",16,0) ;; +---------------------------------------------------------------+ "RTN","MAGDRPC3",17,0) ;; "RTN","MAGDRPC3",18,0) Q "RTN","MAGDRPC3",19,0) ; "RTN","MAGDRPC3",20,0) RADLKUP(OUT,CASENUMB,STUDYDAT) ; RPC = MAG DICOM LOOKUP RAD STUDY "RTN","MAGDRPC3",21,0) ; Radiology patient/study lookup "RTN","MAGDRPC3",22,0) ; STUDYDAT is a vestigial input parameter, it is not used "RTN","MAGDRPC3",23,0) N ACCNUM ;--- Accession Number "RTN","MAGDRPC3",24,0) N CPTCODE ;-- CPT code for the procedure "RTN","MAGDRPC3",25,0) N CPTNAME ;-- CPT name for the procedure "RTN","MAGDRPC3",26,0) N DATETIME ;- Timestamp "RTN","MAGDRPC3",27,0) N DIVISION ;- pointer to INSTITUTION file (#4) "RTN","MAGDRPC3",28,0) N EXAMSTS ;-- Exam status (don't post images to CANCELLED exams) "RTN","MAGDRPC3",29,0) N PROCDESC ;- Procedure description "RTN","MAGDRPC3",30,0) N PROCIEN ;-- radiology procedure ien in ^RAMIS(71) "RTN","MAGDRPC3",31,0) N RAA ;------ array for returned value "RTN","MAGDRPC3",32,0) N RAIX ;----- cross reference subscript for case number lookup "RTN","MAGDRPC3",33,0) N RADPT1 ;--- first level subscript in ^RADPT "RTN","MAGDRPC3",34,0) N RADPT2 ;--- second level subscript in ^RADPT (after "DT") "RTN","MAGDRPC3",35,0) N RADPT3 ;--- third level subscript in ^RADPT (after "P") "RTN","MAGDRPC3",36,0) N D1,I,LIST,X,Z "RTN","MAGDRPC3",37,0) ; "RTN","MAGDRPC3",38,0) ; find the patient/study in ^RADPT using the Radiology Case Number "RTN","MAGDRPC3",39,0) K OUT "RTN","MAGDRPC3",40,0) ; "RTN","MAGDRPC3",41,0) I $G(CASENUMB)="" S OUT(1)="-1,No Case Number Specified" Q "RTN","MAGDRPC3",42,0) ; "RTN","MAGDRPC3",43,0) S X=$$ACCFIND^RAAPI(CASENUMB,.RAA) ; IA 5020 "RTN","MAGDRPC3",44,0) ; "RTN","MAGDRPC3",45,0) I X<0 S OUT(1)="-2,Error in Accession Number Lookup: <<"_X_">>" Q "RTN","MAGDRPC3",46,0) ; "RTN","MAGDRPC3",47,0) S RADPT1=$P(RAA(1),"^",1),RADPT2=$P(RAA(1),"^",2),RADPT3=$P(RAA(1),"^",3) "RTN","MAGDRPC3",48,0) ; "RTN","MAGDRPC3",49,0) I RADPT1="" S OUT(1)="-3,Null RADPT1 entry returned by $$ACCFIND^RAAPI" Q "RTN","MAGDRPC3",50,0) I RADPT2="" S OUT(1)="-4,Null RADPT2 entry returned by $$ACCFIND^RAAPI" Q "RTN","MAGDRPC3",51,0) I RADPT3="" S OUT(1)="-5,Null RADPT3 entry returned by $$ACCFIND^RAAPI" Q "RTN","MAGDRPC3",52,0) ; "RTN","MAGDRPC3",53,0) I '$D(^RADPT(RADPT1,0)) S OUT(1)="-6,No patient demographics file pointer" Q "RTN","MAGDRPC3",54,0) ; "RTN","MAGDRPC3",55,0) ; get patient demographics file pointer "RTN","MAGDRPC3",56,0) S DFN=$P(^RADPT(RADPT1,0),"^",1) "RTN","MAGDRPC3",57,0) ; "RTN","MAGDRPC3",58,0) I '$D(^RADPT(RADPT1,"DT",RADPT2,0)) S OUT(1)="-7,No date/time level" Q "RTN","MAGDRPC3",59,0) ; "RTN","MAGDRPC3",60,0) ; get date and time of examination "RTN","MAGDRPC3",61,0) S DATETIME=$P($G(^RADPT(RADPT1,"DT",RADPT2,0)),"^",1) "RTN","MAGDRPC3",62,0) ; get case info "RTN","MAGDRPC3",63,0) ; "RTN","MAGDRPC3",64,0) I '$D(^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,0)) S OUT(1)="-8,No study level" Q "RTN","MAGDRPC3",65,0) ; "RTN","MAGDRPC3",66,0) S X=^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,0) "RTN","MAGDRPC3",67,0) S Z=$P(X,"^",17) I Z S Z=$$ACCRPT^RAAPI(Z,.RAA) S ACCNUM=RAA(1) "RTN","MAGDRPC3",68,0) S PROCIEN=$P(X,"^",2),EXAMSTS=$P(X,"^",3) "RTN","MAGDRPC3",69,0) S:EXAMSTS EXAMSTS=$$GET1^DIQ(72,EXAMSTS,.01) "RTN","MAGDRPC3",70,0) S (PROCDESC,CPTNAME,CPTCODE)="" "RTN","MAGDRPC3",71,0) ; "RTN","MAGDRPC3",72,0) ; need PROCIEN to do lookup in ^RAMIS "RTN","MAGDRPC3",73,0) I 'PROCIEN S OUT(1)="-9,No procedure identifier" Q "RTN","MAGDRPC3",74,0) ; "RTN","MAGDRPC3",75,0) S Z=$G(^RAMIS(71,PROCIEN,0)) "RTN","MAGDRPC3",76,0) S PROCDESC=$P(Z,"^",1),CPTCODE=$P(Z,"^",9) "RTN","MAGDRPC3",77,0) S CPTNAME=$P($$CPT^ICPTCOD(+CPTCODE),"^",3) ; IA 1995 "RTN","MAGDRPC3",78,0) S:CPTNAME="" CPTNAME=PROCDESC "RTN","MAGDRPC3",79,0) S OUT(2)=$G(RADPT1) "RTN","MAGDRPC3",80,0) S OUT(3)=$G(RADPT2) "RTN","MAGDRPC3",81,0) S OUT(4)=$G(RADPT3) "RTN","MAGDRPC3",82,0) S OUT(5)=$G(PROCIEN) "RTN","MAGDRPC3",83,0) S OUT(6)=$G(CPTCODE) "RTN","MAGDRPC3",84,0) S OUT(7)=$G(CPTNAME) "RTN","MAGDRPC3",85,0) S OUT(8)=$G(Z) "RTN","MAGDRPC3",86,0) S OUT(9)=$G(EXAMSTS) "RTN","MAGDRPC3",87,0) S OUT(10)=$G(DFN) "RTN","MAGDRPC3",88,0) S OUT(11)=$G(DATETIME) "RTN","MAGDRPC3",89,0) S OUT(12)=$G(PROCDESC) "RTN","MAGDRPC3",90,0) S X="" "RTN","MAGDRPC3",91,0) I $G(PROCIEN) S D1=0 F S D1=$O(^RAMIS(71,PROCIEN,"MDL",D1)) Q:'D1 D "RTN","MAGDRPC3",92,0) . S Z=+$P($G(^RAMIS(71,PROCIEN,"MDL",D1,0)),"^",1) Q:'Z "RTN","MAGDRPC3",93,0) . S Z=$P($G(^RAMIS(73.1,Z,0)),"^",1) Q:Z="" "RTN","MAGDRPC3",94,0) . S:X'="" X=X_"," S X=X_Z "RTN","MAGDRPC3",95,0) . Q "RTN","MAGDRPC3",96,0) S OUT(13)=X ; List of Modality-codes "RTN","MAGDRPC3",97,0) S X="" I $G(RADPT1),$G(RADPT2) S X=$G(^RADPT(RADPT1,"DT",RADPT2,0)) "RTN","MAGDRPC3",98,0) S DIVISION=$P(X,"^",3) ; pointer to INSTITUTION file (#4) for division "RTN","MAGDRPC3",99,0) S OUT(14)=$S($$ISIHS^MAGSPID():$P($$SITE^VASITE(),"^",3),1:$E($$GET1^DIQ(4,DIVISION,99),1,3)) ; station number, exclusive of any modifiers "RTN","MAGDRPC3",100,0) ; Patient's pregnancy status at the time of the exam "RTN","MAGDRPC3",101,0) S X="" I $G(DFN),$G(RADPT2),$G(RADPT3) S X=$G(^RADPT(DFN,"DT",RADPT2,"P",RADPT3,0)) "RTN","MAGDRPC3",102,0) S OUT(15)=$P($G(^RAO(75.1,+$P(X,"^",11),0)),"^",13) "RTN","MAGDRPC3",103,0) S OUT(16)=$G(ACCNUM) "RTN","MAGDRPC3",104,0) S OUT(1)=1 ; OK "RTN","MAGDRPC3",105,0) Q "RTN","MAGDRPC3",106,0) ; "RTN","MAGDRPC3",107,0) QUEUE(OUT,IMAGE,APPNAM,LOCATION,ACCNUM,REASON,EMAIL,PRIOR,JBTOHD) ; RPC = MAG DICOM QUEUE IMAGE "RTN","MAGDRPC3",108,0) ; Add the DICOM study send image request to the queue "RTN","MAGDRPC3",109,0) N COUNT,D0,D1,DFN,LOG,OK,P,PROBLEM,REQUESTDATETIME,STUID,TYPE,X "RTN","MAGDRPC3",110,0) ; "RTN","MAGDRPC3",111,0) K OUT ; RPC return variable "RTN","MAGDRPC3",112,0) I '$G(IMAGE) S OUT="-1,No Image specified" Q "RTN","MAGDRPC3",113,0) I $G(APPNAM)="" S OUT="-2,No Destination specified" Q "RTN","MAGDRPC3",114,0) I '$G(LOCATION) S OUT="-3,No Origin specified" Q "RTN","MAGDRPC3",115,0) S PRIOR=+$G(PRIOR) S:'PRIOR PRIOR=500 "RTN","MAGDRPC3",116,0) S JBTOHD=$S($G(JBTOHD):1,1:0) "RTN","MAGDRPC3",117,0) ; "RTN","MAGDRPC3",118,0) S X=$G(^MAG(2005,IMAGE,0)) "RTN","MAGDRPC3",119,0) S TYPE=+$P(X,"^",6),DFN=$P(X,"^",7) "RTN","MAGDRPC3",120,0) I " 0 11 3 100 "'[(" "_TYPE_" ") D Q "RTN","MAGDRPC3",121,0) . S OUT="-4,Cannot Queue Image Object Type """_TYPE_"""." "RTN","MAGDRPC3",122,0) . Q "RTN","MAGDRPC3",123,0) ; "RTN","MAGDRPC3",124,0) L +^MAGDOUTP(2006.574):1E9 ; P180 DAC - Lock global, background process MUST wait "RTN","MAGDRPC3",125,0) S P=$P($G(^MAG(2005,IMAGE,0)),"^",10),P=$S(P:P,1:IMAGE) "RTN","MAGDRPC3",126,0) S STUID=$P($G(^MAG(2005,P,"PACS")),"^",1) S:STUID="" STUID="?" "RTN","MAGDRPC3",127,0) S OK=0,D0="" F S D0=$O(^MAGDOUTP(2006.574,"STUDY",STUID,D0)) Q:'D0 D Q:OK "RTN","MAGDRPC3",128,0) . Q:'$D(^MAGDOUTP(2006.574,"STS",LOCATION,PRIOR,"WAITING",D0)) "RTN","MAGDRPC3",129,0) . Q:$P($G(^MAGDOUTP(2006.574,D0,0)),"^",1)'=APPNAM "RTN","MAGDRPC3",130,0) . S OK=D0 "RTN","MAGDRPC3",131,0) . Q "RTN","MAGDRPC3",132,0) S D0=OK D:'D0 "RTN","MAGDRPC3",133,0) . I $G(ACCNUM)="" D Q:$D(OUT) ; get the accession number (it's sometimes not passed) "RTN","MAGDRPC3",134,0) . . N RESULT "RTN","MAGDRPC3",135,0) . . D LOOKUP^MAGDRPCA(.RESULT,P) "RTN","MAGDRPC3",136,0) . . I RESULT<0 S OUT="-4,Accession Number Lookup Problem: "_RESULT "RTN","MAGDRPC3",137,0) . . E S ACCNUM=$P(RESULT,"^",8) "RTN","MAGDRPC3",138,0) . . Q "RTN","MAGDRPC3",139,0) . S X=$G(^MAGDOUTP(2006.574,0)) "RTN","MAGDRPC3",140,0) . S $P(X,"^",1,2)="DICOM OBJECT EXPORT^2006.574" "RTN","MAGDRPC3",141,0) . S D0=$O(^MAGDOUTP(2006.574," "),-1)+1 ; Next number "RTN","MAGDRPC3",142,0) . S $P(X,"^",3)=D0 "RTN","MAGDRPC3",143,0) . S $P(X,"^",4)=$P(X,"^",4)+1 ; Total count "RTN","MAGDRPC3",144,0) . S ^MAGDOUTP(2006.574,0)=X "RTN","MAGDRPC3",145,0) . ; "RTN","MAGDRPC3",146,0) . S REQUESTDATETIME=$$NOW^XLFDT "RTN","MAGDRPC3",147,0) . S ^MAGDOUTP(2006.574,D0,0)=APPNAM_"^"_P_"^"_ACCNUM_"^"_LOCATION_"^"_PRIOR_"^"_JBTOHD_"^"_REQUESTDATETIME "RTN","MAGDRPC3",148,0) . S ^MAGDOUTP(2006.574,"C",REQUESTDATETIME,D0)="" ; cross reference to delete old studies "RTN","MAGDRPC3",149,0) . S ^MAGDOUTP(2006.574,D0,2)=STUID "RTN","MAGDRPC3",150,0) . S ^MAGDOUTP(2006.574,"STUDY",STUID,D0)="" "RTN","MAGDRPC3",151,0) . Q "RTN","MAGDRPC3",152,0) L -^MAGDOUTP(2006.574) "RTN","MAGDRPC3",153,0) Q:$D(OUT) ; problem with accesion number lookup "RTN","MAGDRPC3",154,0) ; "RTN","MAGDRPC3",155,0) S COUNT=0,PROBLEM=3 "RTN","MAGDRPC3",156,0) I (TYPE=3)!(TYPE=100) D ; Single XRAY or DICOM image "RTN","MAGDRPC3",157,0) . S COUNT=COUNT+$$ENQUEUE(IMAGE,D0,PRIOR) "RTN","MAGDRPC3",158,0) . Q "RTN","MAGDRPC3",159,0) I TYPE=11 D ; Process all the images in an XRAY group "RTN","MAGDRPC3",160,0) . S D1=0 F S D1=$O(^MAG(2005,IMAGE,1,D1)) Q:'D1 D "RTN","MAGDRPC3",161,0) . . S COUNT=COUNT+$$ENQUEUE($P($G(^MAG(2005,IMAGE,1,D1,0)),"^",1),D0,PRIOR) "RTN","MAGDRPC3",162,0) . . Q "RTN","MAGDRPC3",163,0) . Q "RTN","MAGDRPC3",164,0) ; "RTN","MAGDRPC3",165,0) S LOG="DICOM transmit to "_APPNAM_" for reason "_REASON "RTN","MAGDRPC3",166,0) D:COUNT ENTRY^MAGLOG($C(REASON+64),DUZ,IMAGE,"DICOM Gateway",DFN,COUNT,LOG) "RTN","MAGDRPC3",167,0) D:PROBLEM>3 "RTN","MAGDRPC3",168,0) . N XMERR,XMID,XMSUB,XMY,XMZ "RTN","MAGDRPC3",169,0) . S PROBLEM(1)="Error while queueing image for Transmission:" "RTN","MAGDRPC3",170,0) . S PROBLEM(2)=LOG "RTN","MAGDRPC3",171,0) . S PROBLEM(3)=" " "RTN","MAGDRPC3",172,0) . ; --- send MailMan message... "RTN","MAGDRPC3",173,0) . S XMID=$G(DUZ) S:'XMID XMID=.5 "RTN","MAGDRPC3",174,0) . S XMY(XMID)="" "RTN","MAGDRPC3",175,0) . S:$G(EMAIL)'="" XMY(EMAIL)="" "RTN","MAGDRPC3",176,0) . S XMSUB=$E("Cannot transmit image(s) to "_APPNAM,1,63) "RTN","MAGDRPC3",177,0) . D SENDMSG^XMXAPI(XMID,XMSUB,"PROBLEM",.XMY,,.XMZ,) "RTN","MAGDRPC3",178,0) . Q:'$G(XMERR) "RTN","MAGDRPC3",179,0) . M XMERR=^TMP("XMERR",$J) S $EC=",U13-Cannot send MailMan message," "RTN","MAGDRPC3",180,0) . Q "RTN","MAGDRPC3",181,0) S OUT=1 "RTN","MAGDRPC3",182,0) Q "RTN","MAGDRPC3",183,0) ; "RTN","MAGDRPC3",184,0) ENQUEUE(IMAGE,D0,PRIOR) ; Add an image to the DICOM send image request queue sub-file "RTN","MAGDRPC3",185,0) Q:'IMAGE 0 "RTN","MAGDRPC3",186,0) N D1,I,OLD,X "RTN","MAGDRPC3",187,0) D CHK^MAGGSQI(.X,IMAGE) I +$G(X(0))'=1 D Q 0 "RTN","MAGDRPC3",188,0) . S PROBLEM=PROBLEM+1,PROBLEM(PROBLEM)=" " "RTN","MAGDRPC3",189,0) . S PROBLEM=PROBLEM+1,PROBLEM(PROBLEM)="Image # "_IMAGE_":" "RTN","MAGDRPC3",190,0) . S I="" F S I=$O(X(I)) Q:I="" S PROBLEM=PROBLEM+1,PROBLEM(PROBLEM)=X(I) "RTN","MAGDRPC3",191,0) . Q "RTN","MAGDRPC3",192,0) ; "RTN","MAGDRPC3",193,0) ; Enter each image at most once in each transmission request "RTN","MAGDRPC3",194,0) S (D1,OLD)=0 F S D1=$O(^MAGDOUTP(2006.574,D0,1,D1)) Q:'D1 D Q:OLD "RTN","MAGDRPC3",195,0) . S:$P($G(^MAGDOUTP(2006.574,D0,1,D1,0)),"^",1)=IMAGE OLD=1 "RTN","MAGDRPC3",196,0) . Q "RTN","MAGDRPC3",197,0) Q:OLD 1 "RTN","MAGDRPC3",198,0) ; "RTN","MAGDRPC3",199,0) L +^MAGDOUTP(2006.574):1E9 ; P180 DAC - Lock global, background Process MUST wait "RTN","MAGDRPC3",200,0) S X=$G(^MAGDOUTP(2006.574,D0,1,0)) "RTN","MAGDRPC3",201,0) S $P(X,"^",1,2)="^2006.5744" "RTN","MAGDRPC3",202,0) S D1=$O(^MAGDOUTP(2006.574,D0,1," "),-1)+1,$P(X,"^",3)=D1 "RTN","MAGDRPC3",203,0) S $P(X,"^",4)=$P(X,"^",4)+1,OUT=$P(X,"^",4) "RTN","MAGDRPC3",204,0) S ^MAGDOUTP(2006.574,D0,1,0)=X "RTN","MAGDRPC3",205,0) S ^MAGDOUTP(2006.574,D0,1,D1,0)=IMAGE_"^WAITING^"_$H "RTN","MAGDRPC3",206,0) S ^MAGDOUTP(2006.574,"STS",LOCATION,PRIOR,"WAITING",D0,D1)="" "RTN","MAGDRPC3",207,0) L -^MAGDOUTP(2006.574) "RTN","MAGDRPC3",208,0) Q 1 "RTN","MAGDRPC3",209,0) ; "RTN","MAGDRPC3",210,0) FIND(DATE,CASE,NUM) ; ADC x-reference (Radiology patient file) "RTN","MAGDRPC3",211,0) N X "RTN","MAGDRPC3",212,0) Q:'$G(DATE) 0 "RTN","MAGDRPC3",213,0) S X=DATE S:$G(NUM) X=$$FMADD^XLFDT(DATE,NUM) Q:X<1 0 "RTN","MAGDRPC3",214,0) Q $O(^RADPT("ADC",$$MMDDYY(X)_"-"_CASE,"")) "RTN","MAGDRPC3",215,0) ; "RTN","MAGDRPC3",216,0) MMDDYY(DAY) ; YYYMMDD --> MMDDYY "RTN","MAGDRPC3",217,0) I DAY'?7N Q 0 "RTN","MAGDRPC3",218,0) Q $E(DAY,4,7)_$E(DAY,2,3) "RTN","MAGDRPC3",219,0) ; "RTN","MAGDRPC4") 0^2^B106996677 "RTN","MAGDRPC4",1,0) MAGDRPC4 ;WOIFO/EdM,DAC - Imaging RPCs ; 24 Oct 2017 4:39 PM "RTN","MAGDRPC4",2,0) ;;3.0;IMAGING;**11,30,51,50,54,49,138,156,180**;Mar 19, 2002;Build 16 "RTN","MAGDRPC4",3,0) ;; Per VHA Directive 2004-038, this routine should not be modified. "RTN","MAGDRPC4",4,0) ;; +---------------------------------------------------------------+ "RTN","MAGDRPC4",5,0) ;; | Property of the US Government. | "RTN","MAGDRPC4",6,0) ;; | No permission to copy or redistribute this software is given. | "RTN","MAGDRPC4",7,0) ;; | Use of unreleased versions of this software requires the user | "RTN","MAGDRPC4",8,0) ;; | to execute a written test agreement with the VistA Imaging | "RTN","MAGDRPC4",9,0) ;; | Development Office of the Department of Veterans Affairs, | "RTN","MAGDRPC4",10,0) ;; | telephone (301) 734-0100. | "RTN","MAGDRPC4",11,0) ;; | The Food and Drug Administration classifies this software as | "RTN","MAGDRPC4",12,0) ;; | a medical device. As such, it may not be changed in any way. | "RTN","MAGDRPC4",13,0) ;; | Modifications to this software may result in an adulterated | "RTN","MAGDRPC4",14,0) ;; | medical device under 21CFR820, the use of which is considered | "RTN","MAGDRPC4",15,0) ;; | to be a violation of US Federal Statutes. | "RTN","MAGDRPC4",16,0) ;; +---------------------------------------------------------------+ "RTN","MAGDRPC4",17,0) ;; "RTN","MAGDRPC4",18,0) Q "RTN","MAGDRPC4",19,0) ; "RTN","MAGDRPC4",20,0) LOOKUP(OUT,NUMBER) ; RPC = MAG DICOM LOOKUP STUDY "RTN","MAGDRPC4",21,0) ; Look Up for both Radiology and Consults "RTN","MAGDRPC4",22,0) N ACCNUM ;--- Accession Number "RTN","MAGDRPC4",23,0) N CPTCODE ;-- CPT code for the procedure "RTN","MAGDRPC4",24,0) N CPTNAME ;-- CPT name for the procedure "RTN","MAGDRPC4",25,0) N DFN ;------ Patient pointer "RTN","MAGDRPC4",26,0) N EXAMSTS ;-- Exam status (don't post images to CANCELLED exams) "RTN","MAGDRPC4",27,0) N EXAMTYPE ;- Type of exam (Rad,Con, or Lab) "RTN","MAGDRPC4",28,0) N GMRCIEN ;-- Pointer for GMRC "RTN","MAGDRPC4",29,0) N INFO ;----- return array from $$ACCRPT^RAAPI() "RTN","MAGDRPC4",30,0) N PROCDESC ;- Procedure description "RTN","MAGDRPC4",31,0) N PROCIEN ;-- Radiology procedure IEN in ^RAMIS(71) "RTN","MAGDRPC4",32,0) N RAA ;------ Radiology array (for $$ACCFIND) "RTN","MAGDRPC4",33,0) N RAIX ;----- cross reference subscript for case number lookup "RTN","MAGDRPC4",34,0) N RADFN ;---- first level subscript in ^RADPT "RTN","MAGDRPC4",35,0) N RADTI ;---- second level subscript in ^RADPT (after "DT") "RTN","MAGDRPC4",36,0) N RACNI ;---- third level subscript in ^RADPT (after "P") "RTN","MAGDRPC4",37,0) N RARPT ;---- Radiology Report pointer "RTN","MAGDRPC4",38,0) N I,LIST,NOUT,X,Y,Z "RTN","MAGDRPC4",39,0) ; "RTN","MAGDRPC4",40,0) K OUT S NOUT=1 "RTN","MAGDRPC4",41,0) I $G(NUMBER)="" S OUT(1)="-1,No Case or Consult Number Specified" Q "RTN","MAGDRPC4",42,0) I $E(NUMBER,2)="`" D Q "RTN","MAGDRPC4",43,0) . ; lookup the image by the IEN "RTN","MAGDRPC4",44,0) . D IENLOOK^MAGDRPC9 "RTN","MAGDRPC4",45,0) . Q "RTN","MAGDRPC4",46,0) ; "RTN","MAGDRPC4",47,0) S EXAMTYPE=$E(NUMBER,1) "RTN","MAGDRPC4",48,0) I "RCL"[EXAMTYPE S NUMBER=$E(NUMBER,2,$L(NUMBER)) "RTN","MAGDRPC4",49,0) E S EXAMTYPE="" "RTN","MAGDRPC4",50,0) K DFN "RTN","MAGDRPC4",51,0) D RADLKUP ; First try Radiology candidates "RTN","MAGDRPC4",52,0) I '$D(OUT(1)) D CONLKUP ; Then try CPRS consult/procedure "RTN","MAGDRPC4",53,0) I '$D(OUT(1)) D LABLKUP ; Finally try Lab "RTN","MAGDRPC4",54,0) I '$D(OUT(1)) S OUT(1)=NOUT-1 ; allow error messages to be passed back in OUT(1) "RTN","MAGDRPC4",55,0) Q "RTN","MAGDRPC4",56,0) ; "RTN","MAGDRPC4",57,0) RADLKUP ; Radiology lookup "RTN","MAGDRPC4",58,0) I EXAMTYPE'="",EXAMTYPE'="R" Q "RTN","MAGDRPC4",59,0) S RACNI=0 ; must get this value to find study "RTN","MAGDRPC4",60,0) I NUMBER?1N.N D Q:'RACNI "RTN","MAGDRPC4",61,0) . ; Look for the patient/study in ^RADPT using the Radiology Case Number "RTN","MAGDRPC4",62,0) . N RAIX ;----- cross reference subscript for case number lookup "RTN","MAGDRPC4",63,0) . S RAIX=$S($D(^RADPT("C")):"C",1:"AE") ; for Radiology Patch RA*5*7 "RTN","MAGDRPC4",64,0) . S RAIX=$S(NUMBER["-":"ADC",1:RAIX) ; select the cross-reference "RTN","MAGDRPC4",65,0) . S RADFN=$O(^RADPT(RAIX,NUMBER,"")) Q:'RADFN "RTN","MAGDRPC4",66,0) . S RADTI=$O(^RADPT(RAIX,NUMBER,RADFN,"")) "RTN","MAGDRPC4",67,0) . S RACNI=$O(^RADPT(RAIX,NUMBER,RADFN,RADTI,"")) "RTN","MAGDRPC4",68,0) . Q "RTN","MAGDRPC4",69,0) E D Q:'RACNI ; lookup using Radiololgy Package API "RTN","MAGDRPC4",70,0) . S X=$$ACCFIND^RAAPI(NUMBER,.RAA) "RTN","MAGDRPC4",71,0) . I X<0 Q "RTN","MAGDRPC4",72,0) . S Y=RAA(1) "RTN","MAGDRPC4",73,0) . S RADFN=$P(Y,"^",1),RADTI=$P(Y,"^",2),RACNI=$P(Y,"^",3) "RTN","MAGDRPC4",74,0) . Q "RTN","MAGDRPC4",75,0) Q:'$D(^RADPT(RADFN,0)) ; No patient demographics file pointer "RTN","MAGDRPC4",76,0) S DFN=$P(^RADPT(RADFN,0),"^",1) "RTN","MAGDRPC4",77,0) Q:'$G(DFN) "RTN","MAGDRPC4",78,0) Q:'$D(^RADPT(DFN,"DT",RADTI,0)) "RTN","MAGDRPC4",79,0) S RARPT=$P($G(^RADPT(DFN,"DT",RADTI,"P",RACNI,0)),"^",17) Q:'RARPT "RTN","MAGDRPC4",80,0) S X=$$ACCRPT^RAAPI(RARPT,.INFO) "RTN","MAGDRPC4",81,0) I X<0 S OUT(1)="-11,Radiology Problem: "_X Q "RTN","MAGDRPC4",82,0) S ACCNUM=INFO(1) "RTN","MAGDRPC4",83,0) S I=0 F S I=$O(^RARPT(RARPT,2005,I)) Q:'I D "RTN","MAGDRPC4",84,0) . S X="74^"_RARPT_"^"_$P($G(^RARPT(RARPT,2005,I,0)),"^",1)_"^"_ACCNUM "RTN","MAGDRPC4",85,0) . S NOUT=NOUT+1,OUT(NOUT)=X "RTN","MAGDRPC4",86,0) . Q "RTN","MAGDRPC4",87,0) Q "RTN","MAGDRPC4",88,0) ; "RTN","MAGDRPC4",89,0) CONLKUP ; CPRS Consult/Procedure study lookup "RTN","MAGDRPC4",90,0) N ACCNUM,MAGIEN,MAGPTR,REPORTF,REPORTI,TIUIEN,TIUPTR,TIUXIEN,X "RTN","MAGDRPC4",91,0) I EXAMTYPE'="",EXAMTYPE'="C" Q "RTN","MAGDRPC4",92,0) S X=$$GMRCIEN^MAGDFCNV(NUMBER) S GMRCIEN=$S(X:X,1:NUMBER) "RTN","MAGDRPC4",93,0) S ACCNUM=$$GMRCACN^MAGDFCNV(GMRCIEN) "RTN","MAGDRPC4",94,0) D "RTN","MAGDRPC4",95,0) . N D0,Z "RTN","MAGDRPC4",96,0) . S D0=GMRCIEN "RTN","MAGDRPC4",97,0) . S DFN=$$GET1^DIQ(123,D0,.02,"I") Q:'DFN "RTN","MAGDRPC4",98,0) . S EXAMSTS=$$GET1^DIQ(123,D0,8) ; check for cancelled exam "RTN","MAGDRPC4",99,0) . I EXAMSTS="CANCELLED" S OUT(1)="-4,Consult is cancelled" Q "RTN","MAGDRPC4",100,0) . S PROCDESC=$$GET1^DIQ(123,D0,1) "RTN","MAGDRPC4",101,0) . S Z=$$GET1^DIQ(123,D0,13,"I") ; request type "RTN","MAGDRPC4",102,0) . Q "RTN","MAGDRPC4",103,0) I '$G(DFN) S OUT(1)="-5,Consult/procedure not on file" Q "RTN","MAGDRPC4",104,0) ; Find the images - they can be linked to TIU or imaging file 2006.5839 "RTN","MAGDRPC4",105,0) S MAGPTR=$O(^MAG(2006.5839,"C",123,GMRCIEN,0)) "RTN","MAGDRPC4",106,0) I MAGPTR D Q ; Found it in ^MAG(2006.5839) - not in ^TIU yet "RTN","MAGDRPC4",107,0) . S X=^MAG(2006.5839,MAGPTR,0) "RTN","MAGDRPC4",108,0) . S X=$P(X,"^",1)_"^"_$P(X,"^",2)_"^"_$P(X,"^",3)_"^"_ACCNUM "RTN","MAGDRPC4",109,0) . S NOUT=NOUT+1,OUT(NOUT)=X "RTN","MAGDRPC4",110,0) . Q "RTN","MAGDRPC4",111,0) D ; Otherwise find images in ^TIU "RTN","MAGDRPC4",112,0) . N I,RESULT,X "RTN","MAGDRPC4",113,0) . D TIUALL^MAGDGMRC(GMRCIEN,.RESULT) "RTN","MAGDRPC4",114,0) . S I="" F S I=$O(RESULT(I)) Q:I="" D "RTN","MAGDRPC4",115,0) . . S X="8925^"_$P(RESULT(I),"^",1)_"^"_$P(RESULT(I),"^",3)_"^"_$P(RESULT(I),"^",2) "RTN","MAGDRPC4",116,0) . . S NOUT=NOUT+1,OUT(NOUT)=X "RTN","MAGDRPC4",117,0) . . Q "RTN","MAGDRPC4",118,0) . Q "RTN","MAGDRPC4",119,0) Q "RTN","MAGDRPC4",120,0) ; "RTN","MAGDRPC4",121,0) LABLKUP ; Lab (Anatomic Pathology) study lookup "RTN","MAGDRPC4",122,0) N ACNUMB,FILEDATA,LRDFN,LRI,LRSS,MAGIEN,MAGPTR,PARENTFILE,PROCDESC,TIUIEN,TIUXIEN,X "RTN","MAGDRPC4",123,0) I EXAMTYPE'="",EXAMTYPE'="L" Q "RTN","MAGDRPC4",124,0) S ACNUMB=NUMBER D LABLKUP^MAGDIR8A "RTN","MAGDRPC4",125,0) I '$G(DFN) S OUT(1)="-6,Anatomic Pathology case not on file" Q "RTN","MAGDRPC4",126,0) D SUBFILES^MAGDIR9F(LRSS) "RTN","MAGDRPC4",127,0) ; Find the images - they can be linked to TIU or imaging file 2006.5838 "RTN","MAGDRPC4",128,0) S MAGPTR=$O(^MAG(2006.5838,"C",PARENTFILE,LRDFN,LRI,0)) "RTN","MAGDRPC4",129,0) I MAGPTR D Q ; Found it in ^MAG(2006.5838) - not in ^TIU yet "RTN","MAGDRPC4",130,0) . S X=^MAG(2006.5838,MAGPTR,0) "RTN","MAGDRPC4",131,0) . ; separate the two subscripts that point to the study with a comma "RTN","MAGDRPC4",132,0) . S X=$P(X,"^",1)_"^"_$P(X,"^",2)_","_$P(X,"^",3)_"^"_$P(X,"^",4)_"^"_ACNUMB "RTN","MAGDRPC4",133,0) . S NOUT=NOUT+1,OUT(NOUT)=X "RTN","MAGDRPC4",134,0) . Q "RTN","MAGDRPC4",135,0) D ; Otherwise find images in ^TIU "RTN","MAGDRPC4",136,0) . S TIUIEN=$$TIUIEN^MAGT7MA(LRSS,LRDFN,LRI) "RTN","MAGDRPC4",137,0) . I TIUIEN D "RTN","MAGDRPC4",138,0) . . S TIUXIEN=$O(^TIU(8925.91,"B",TIUIEN,"")) "RTN","MAGDRPC4",139,0) . . I TIUXIEN D "RTN","MAGDRPC4",140,0) . . . S MAGIEN=$$GET1^DIQ(8925.91,TIUXIEN,.02,"I") "RTN","MAGDRPC4",141,0) . . . S X="8925^"_TIUIEN_"^"_MAGIEN_"^"_ACNUMB "RTN","MAGDRPC4",142,0) . . . S NOUT=NOUT+1,OUT(NOUT)=X "RTN","MAGDRPC4",143,0) . . . Q "RTN","MAGDRPC4",144,0) . . Q "RTN","MAGDRPC4",145,0) . Q "RTN","MAGDRPC4",146,0) Q "RTN","MAGDRPC4",147,0) ; "RTN","MAGDRPC4",148,0) NEXTIMG(OUT,FROMS,SENT,CHECK) ; RPC = MAG DICOM GET NEXT QUEUE ENTRY "RTN","MAGDRPC4",149,0) ; Get next file to be DICOM transmitted "RTN","MAGDRPC4",150,0) N H,F1,F2,F3,FROM,I,JBTOHD,LOC,N,PRI,S0,S1,STS,TYPE,X "RTN","MAGDRPC4",151,0) S X=$G(FROMS) S:X FROM(X)=1 "RTN","MAGDRPC4",152,0) S I="" F S I=$O(FROMS(I)) Q:I="" S X=$G(FROMS(I)) S:X FROM(X)=1 "RTN","MAGDRPC4",153,0) I '$O(FROM("")) S OUT(1)="-1,No Origin Specified" Q "RTN","MAGDRPC4",154,0) ; First clean up transmitted queue entries "RTN","MAGDRPC4",155,0) S I="" F S I=$O(SENT(I)) Q:I="" D CLEAN^MAGDRPC9 "RTN","MAGDRPC4",156,0) S H=$$SECOND($H) "RTN","MAGDRPC4",157,0) L +^MAGDOUTP(2006.574):1E9 ; P180 DAC - Lock entire global, background process MUST wait "RTN","MAGDRPC4",158,0) I '$G(CHECK) D ; do only when called from a transmission process "RTN","MAGDRPC4",159,0) . S FROM="" F S FROM=$O(FROM(FROM)) Q:FROM="" D "RTN","MAGDRPC4",160,0) . . S PRI="" F S PRI=$O(^MAGDOUTP(2006.574,"STS",FROM,PRI)) Q:PRI="" D "RTN","MAGDRPC4",161,0) . . . S S0="" F S S0=$O(^MAGDOUTP(2006.574,"STS",FROM,PRI,"XMIT",S0)) Q:S0="" D "RTN","MAGDRPC4",162,0) . . . . S S1="" F S S1=$O(^MAGDOUTP(2006.574,"STS",FROM,PRI,"XMIT",S0,S1)) Q:S1="" D "RTN","MAGDRPC4",163,0) . . . . . S X=$$SECOND($P($G(^MAGDOUTP(2006.574,S0,1,S1,0),"^^"_$H),"^",3)) "RTN","MAGDRPC4",164,0) . . . . . Q:H-X<300 "RTN","MAGDRPC4",165,0) . . . . . S $P(^MAGDOUTP(2006.574,S0,1,S1,0),"^",2)="WAITING" "RTN","MAGDRPC4",166,0) . . . . . K ^MAGDOUTP(2006.574,"STS",FROM,PRI,"XMIT",S0,S1) "RTN","MAGDRPC4",167,0) . . . . . S ^MAGDOUTP(2006.574,"STS",FROM,PRI,"WAITING",S0,S1)="" "RTN","MAGDRPC4",168,0) . . . . . Q "RTN","MAGDRPC4",169,0) . . . . Q "RTN","MAGDRPC4",170,0) . . . Q "RTN","MAGDRPC4",171,0) . . Q "RTN","MAGDRPC4",172,0) . Q "RTN","MAGDRPC4",173,0) ; Find the highest priority among the selected FROM locations "RTN","MAGDRPC4",174,0) S FROM="" F S FROM=$O(FROM(FROM)) Q:FROM="" D "RTN","MAGDRPC4",175,0) . S PRI="" F S PRI=$O(^MAGDOUTP(2006.574,"STS",FROM,PRI)) Q:PRI="" D "RTN","MAGDRPC4",176,0) . . S X=$O(^MAGDOUTP(2006.574,"STS",FROM,PRI,"WAITING","")) S:X PRI(PRI,FROM)="" "RTN","MAGDRPC4",177,0) . . Q "RTN","MAGDRPC4",178,0) . Q "RTN","MAGDRPC4",179,0) S OUT(1)="",PRI=$O(PRI(""),-1) D:PRI'="" "RTN","MAGDRPC4",180,0) . S FROM=$O(PRI(PRI,"")) "RTN","MAGDRPC4",181,0) . S S0="" F S S0=$O(^MAGDOUTP(2006.574,"STS",FROM,PRI,"WAITING",S0)) Q:S0="" D Q:OUT(1)'="" "RTN","MAGDRPC4",182,0) . . S S1="" F S S1=$O(^MAGDOUTP(2006.574,"STS",FROM,PRI,"WAITING",S0,S1)) Q:S1="" D Q:OUT(1)'="" "RTN","MAGDRPC4",183,0) . . . I '$G(CHECK) D ; do only when called from a transmission process "RTN","MAGDRPC4",184,0) . . . . S $P(^MAGDOUTP(2006.574,S0,1,S1,0),"^",2,3)="XMIT^"_$H "RTN","MAGDRPC4",185,0) . . . . K ^MAGDOUTP(2006.574,"STS",FROM,PRI,"WAITING",S0,S1) "RTN","MAGDRPC4",186,0) . . . . S ^MAGDOUTP(2006.574,"STS",FROM,PRI,"XMIT",S0,S1)="" "RTN","MAGDRPC4",187,0) . . . . Q "RTN","MAGDRPC4",188,0) . . . S OUT(1)=1 "RTN","MAGDRPC4",189,0) . . . S OUT(2)=S0 "RTN","MAGDRPC4",190,0) . . . S OUT(3)=S1 "RTN","MAGDRPC4",191,0) . . . S X=$G(^MAGDOUTP(2006.574,S0,0)) "RTN","MAGDRPC4",192,0) . . . S OUT(4)=$P(X,"^",1) ; Application "RTN","MAGDRPC4",193,0) . . . S OUT(5)=$P(X,"^",2) ; Group "RTN","MAGDRPC4",194,0) . . . S OUT(6)=$P(X,"^",3) ; Accession Number "RTN","MAGDRPC4",195,0) . . . S JBTOHD=+$P(X,"^",6) "RTN","MAGDRPC4",196,0) . . . S OUT(7)=+$G(^MAGDOUTP(2006.574,S0,1,S1,0)) ; Image "RTN","MAGDRPC4",197,0) . . . S OUT(8)=$P($G(^MAG(2005,+OUT(7),0)),"^",6) "RTN","MAGDRPC4",198,0) . . . S TYPE=$S($G(^MAG(2005,+OUT(7),"FBIG"))'="":"BIG",1:"FULL") "RTN","MAGDRPC4",199,0) . . . ; 3rd parameter set to 1 to allow retrieval from jukebox "RTN","MAGDRPC4",200,0) . . . D FILEFIND^MAGDFB(+OUT(7),TYPE,1,0,.F1,.F2) "RTN","MAGDRPC4",201,0) . . . S OUT(9)=F1 "RTN","MAGDRPC4",202,0) . . . S OUT(10)=F2 "RTN","MAGDRPC4",203,0) . . . S OUT(11)=$P($G(^MAG(2005,+OUT(7),0)),"^",7) ; P156 DAC - get DFN from image (not group) "RTN","MAGDRPC4",204,0) . . . ; get path for *.TXT, always the same as the FULL file "RTN","MAGDRPC4",205,0) . . . D FILEFIND^MAGDFB(+OUT(7),"FULL",JBTOHD,0,.F1,.F3) "RTN","MAGDRPC4",206,0) . . . S OUT(12)=F3 "RTN","MAGDRPC4",207,0) . . . S X=$G(^MAGDOUTP(2006.574,S0,1,0)) "RTN","MAGDRPC4",208,0) . . . S OUT(13)=$P(X,"^",4) ; Object count "RTN","MAGDRPC4",209,0) . . . Q "RTN","MAGDRPC4",210,0) . . Q "RTN","MAGDRPC4",211,0) . Q "RTN","MAGDRPC4",212,0) I OUT(1)="" D "RTN","MAGDRPC4",213,0) . S OUT(1)="-2,Nothing to be transmitted." "RTN","MAGDRPC4",214,0) . D CLEANUP "RTN","MAGDRPC4",215,0) . Q "RTN","MAGDRPC4",216,0) L -^MAGDOUTP(2006.574) ; P180 DAC - Unlock global "RTN","MAGDRPC4",217,0) Q "RTN","MAGDRPC4",218,0) ; "RTN","MAGDRPC4",219,0) CLEANUP ; remove old studies "RTN","MAGDRPC4",220,0) N I,REQUESTDATETIME,S0,S1,SENT "RTN","MAGDRPC4",221,0) S REQUESTDATETIME=$$FMADD^XLFDT($$NOW^XLFDT,-15,0,0,0) ; delete anything 15 days older or older "RTN","MAGDRPC4",222,0) L +^MAGDOUTP(2006.574):1E9 ; P180 DAC - Lock entire global, background process MUST wait "RTN","MAGDRPC4",223,0) F S REQUESTDATETIME=$O(^MAGDOUTP(2006.574,"C",REQUESTDATETIME),-1) Q:REQUESTDATETIME="" D "RTN","MAGDRPC4",224,0) . S S0="" F S S0=$O(^MAGDOUTP(2006.574,"C",REQUESTDATETIME,S0)) Q:S0="" D "RTN","MAGDRPC4",225,0) . . S S1=0 F S S1=$O(^MAGDOUTP(2006.574,S0,1,S1)) Q:S1="" D "RTN","MAGDRPC4",226,0) . . . S I=1,SENT(1)=S0_"^"_S1_"^" D CLEAN^MAGDRPC9 ; STATUS= "RTN","MAGDRPC4",227,0) . . . Q "RTN","MAGDRPC4",228,0) . . Q "RTN","MAGDRPC4",229,0) . Q "RTN","MAGDRPC4",230,0) L -^MAGDOUTP(2006.574) ; P180 DAC - Unlock global "RTN","MAGDRPC4",231,0) Q "RTN","MAGDRPC4",232,0) ; "RTN","MAGDRPC4",233,0) FIND(DATE,CASE,NUM) ; "RTN","MAGDRPC4",234,0) ; Use the ADC x-reference in the radiology patient file "RTN","MAGDRPC4",235,0) N NDATE "RTN","MAGDRPC4",236,0) S NDATE=$$FMADD^XLFDT(DATE,NUM) Q:NDATE<1 0 "RTN","MAGDRPC4",237,0) Q $O(^RADPT("ADC",$$MMDDYY(NDATE)_"-"_CASE,"")) "RTN","MAGDRPC4",238,0) ; "RTN","MAGDRPC4",239,0) MMDDYY(DAY) ; Convert Fileman date to mmddyy "RTN","MAGDRPC4",240,0) I DAY'?7N Q 0 "RTN","MAGDRPC4",241,0) Q $E(DAY,4,7)_$E(DAY,2,3) "RTN","MAGDRPC4",242,0) ; "RTN","MAGDRPC4",243,0) INIT(OUT,LOCATION) ; RPC = MAG DICOM QUEUE INIT "RTN","MAGDRPC4",244,0) N D0,N,PRI,REQUESTDATETIME,STS,STUID,X "RTN","MAGDRPC4",245,0) I '$G(LOCATION) S OUT="-3,No origin specified." Q "RTN","MAGDRPC4",246,0) I '$D(^MAGDOUTP(2006.574,0)) S OUT="-1,No entries at all in queue." Q "RTN","MAGDRPC4",247,0) ; "RTN","MAGDRPC4",248,0) S N=0 "RTN","MAGDRPC4",249,0) L +^MAGDOUTP(2006.574):1E9 ; P180 DAC - Lock entire global, background process MUST wait "RTN","MAGDRPC4",250,0) S PRI="" F S PRI=$O(^MAGDOUTP(2006.574,"STS",LOCATION,PRI)) Q:PRI="" D "RTN","MAGDRPC4",251,0) . S STS="" F S STS=$O(^MAGDOUTP(2006.574,"STS",LOCATION,PRI,STS)) Q:STS="" D "RTN","MAGDRPC4",252,0) . . S D0="" F S D0=$O(^MAGDOUTP(2006.574,"STS",LOCATION,PRI,STS,D0)) Q:D0="" D "RTN","MAGDRPC4",253,0) . . . S X=$G(^MAGDOUTP(2006.574,D0,0)),REQUESTDATETIME=$P(X,"^",7) "RTN","MAGDRPC4",254,0) . . . S STUID=$G(^MAGDOUTP(2006.574,D0,2)) "RTN","MAGDRPC4",255,0) . . . K ^MAGDOUTP(2006.574,D0) "RTN","MAGDRPC4",256,0) . . . K:REQUESTDATETIME'="" ^MAGDOUTP(2006.574,"C",REQUESTDATETIME,D0) "RTN","MAGDRPC4",257,0) . . . K:STUID'="" ^MAGDOUTP(2006.574,"STUDY",STUID,D0) "RTN","MAGDRPC4",258,0) . . . K ^MAGDOUTP(2006.574,"STS",LOCATION,PRI,STS,D0) "RTN","MAGDRPC4",259,0) . . . S N=N+1 "RTN","MAGDRPC4",260,0) . . . Q "RTN","MAGDRPC4",261,0) . . Q "RTN","MAGDRPC4",262,0) . Q "RTN","MAGDRPC4",263,0) ; "RTN","MAGDRPC4",264,0) ; P180 DAC - Unlock global on early exit "RTN","MAGDRPC4",265,0) I 'N S OUT="-2,No entries present for "_$$GET1^DIQ(4,LOCATION,.01)_"." L -^MAGDOUTP(2006.574) Q "RTN","MAGDRPC4",266,0) ; "RTN","MAGDRPC4",267,0) S $P(^MAGDOUTP(2006.574,0),"^",4)=$P(^MAGDOUTP(2006.574,0),"^",4)-N "RTN","MAGDRPC4",268,0) L -^MAGDOUTP(2006.574) ; P180 DAC - Unlock global "RTN","MAGDRPC4",269,0) S OUT=N_" entr"_$S(N=1:"y",1:"ies")_" removed from Image Transmission Queue." "RTN","MAGDRPC4",270,0) Q "RTN","MAGDRPC4",271,0) ; "RTN","MAGDRPC4",272,0) SECOND(H) Q H*86400+$P(H,",",2) "RTN","MAGDRPC4",273,0) ; "RTN","MAGDRPC9") 0^3^B94046476 "RTN","MAGDRPC9",1,0) MAGDRPC9 ;WOIFO/EdM/MLH/JSL/SAF/DAC/PMK - Imaging RPCs ; 24 Oct 2017 4:38 PM "RTN","MAGDRPC9",2,0) ;;3.0;IMAGING;**50,54,53,49,123,118,138,180**;Mar 19, 2002;Build 16 "RTN","MAGDRPC9",3,0) ;; Per VHA Directive 2004-038, this routine should not be modified. "RTN","MAGDRPC9",4,0) ;; +---------------------------------------------------------------+ "RTN","MAGDRPC9",5,0) ;; | Property of the US Government. | "RTN","MAGDRPC9",6,0) ;; | No permission to copy or redistribute this software is given. | "RTN","MAGDRPC9",7,0) ;; | Use of unreleased versions of this software requires the user | "RTN","MAGDRPC9",8,0) ;; | to execute a written test agreement with the VistA Imaging | "RTN","MAGDRPC9",9,0) ;; | Development Office of the Department of Veterans Affairs, | "RTN","MAGDRPC9",10,0) ;; | telephone (301) 734-0100. | "RTN","MAGDRPC9",11,0) ;; | The Food and Drug Administration classifies this software as | "RTN","MAGDRPC9",12,0) ;; | a medical device. As such, it may not be changed in any way. | "RTN","MAGDRPC9",13,0) ;; | Modifications to this software may result in an adulterated | "RTN","MAGDRPC9",14,0) ;; | medical device under 21CFR820, the use of which is considered | "RTN","MAGDRPC9",15,0) ;; | to be a violation of US Federal Statutes. | "RTN","MAGDRPC9",16,0) ;; +---------------------------------------------------------------+ "RTN","MAGDRPC9",17,0) ;; "RTN","MAGDRPC9",18,0) Q "RTN","MAGDRPC9",19,0) ; "RTN","MAGDRPC9",20,0) UIDROOT(OUT) ; RPC = MAG DICOM GET UID ROOT "RTN","MAGDRPC9",21,0) S OUT=$G(^MAGD(2006.15,1,"UID ROOT")) "RTN","MAGDRPC9",22,0) Q "RTN","MAGDRPC9",23,0) ; "RTN","MAGDRPC9",24,0) NEWUID(OUT,OLD,NEW,IMAGE,DBTYPE) ; RPC = MAG NEW SOP INSTANCE UID "RTN","MAGDRPC9",25,0) N D0,L,X,SOPREC,ORIGSOP "RTN","MAGDRPC9",26,0) S DBTYPE=$G(DBTYPE,"OLD") "RTN","MAGDRPC9",27,0) S IMAGE=+$G(IMAGE),OLD=$G(OLD) "RTN","MAGDRPC9",28,0) S:$G(NEW)="" NEW=OLD "RTN","MAGDRPC9",29,0) D:DBTYPE="OLD" "RTN","MAGDRPC9",30,0) . S D0=IMAGE "RTN","MAGDRPC9",31,0) . I 'D0 S OUT="-2,Cannot find image with UID "_OLD Q "RTN","MAGDRPC9",32,0) . S OUT=$P($G(^MAG(2005,D0,"SOP")),"^",2) Q:OUT'="" "RTN","MAGDRPC9",33,0) . S L=$L(NEW,".")-1,X=$P(NEW,".",L+1),L=$P(NEW,".",1,L)_"." "RTN","MAGDRPC9",34,0) . L +^MAG(2005,"P"):1E9 ; Background process MUST wait "RTN","MAGDRPC9",35,0) . S OUT="" F D Q:OUT'="" "RTN","MAGDRPC9",36,0) . . S OUT=L_X "RTN","MAGDRPC9",37,0) . . I $L(OUT)>64 S OUT="-3,Cannot use "_NEW_" to create valid UID" Q "RTN","MAGDRPC9",38,0) . . I $D(^MAG(2005,"P",OUT)) S OUT="",X=X+1 Q "RTN","MAGDRPC9",39,0) . . S $P(^MAG(2005,D0,"SOP"),"^",2)=OUT "RTN","MAGDRPC9",40,0) . . S ^MAG(2005,"P",OUT,D0)=1 "RTN","MAGDRPC9",41,0) . . Q "RTN","MAGDRPC9",42,0) . L -^MAG(2005,"P") "RTN","MAGDRPC9",43,0) . Q "RTN","MAGDRPC9",44,0) D:DBTYPE="NEW" "RTN","MAGDRPC9",45,0) . S D0=0 S:OLD'="" D0=$O(^MAGV(2005.64,"B",OLD,"")) "RTN","MAGDRPC9",46,0) . I IMAGE,D0,IMAGE'=D0 S OUT="-1,UID cannot belong to multiple images ("_IMAGE_"/"_D0_")" Q "RTN","MAGDRPC9",47,0) . I IMAGE,'D0 S D0=IMAGE "RTN","MAGDRPC9",48,0) . S SOPREC=$G(^MAGV(2005.64,D0,0)) "RTN","MAGDRPC9",49,0) . I SOPREC="" S OUT="-2,IMAGE SOP INSTANCE record not found ("_D0_")" Q "RTN","MAGDRPC9",50,0) . S ORIGSOP=$P(SOPREC,"^",2) "RTN","MAGDRPC9",51,0) . I ORIGSOP'="" D Q "RTN","MAGDRPC9",52,0) . . I OLD=ORIGSOP S OUT=$P(SOPREC,"^",1) Q "RTN","MAGDRPC9",53,0) . . S OUT="-3,ORIGINAL SOP INSTANCE UID for image ("_ORIGSOP "RTN","MAGDRPC9",54,0) . . S OUT=OUT_") does not match value sent ("_OLD "RTN","MAGDRPC9",55,0) . . Q "RTN","MAGDRPC9",56,0) . ; need to verify and store the new SOP "RTN","MAGDRPC9",57,0) . S L=$L(NEW,".")-1,X=$P(NEW,".",L+1),L=$P(NEW,".",1,L)_"." "RTN","MAGDRPC9",58,0) . L +^MAGV(2005.64,"B"):1E9 ; Background process MUST wait "RTN","MAGDRPC9",59,0) . S OUT="" F D Q:OUT'="" "RTN","MAGDRPC9",60,0) . . S OUT=L_X "RTN","MAGDRPC9",61,0) . . I $L(OUT)>64 S OUT="-3,Cannot use "_NEW_" to create valid UID" Q "RTN","MAGDRPC9",62,0) . . I $D(^MAGV(2005.64,"B",OUT)) S OUT="",X=X+1 Q "RTN","MAGDRPC9",63,0) . . S $P(SOPREC,"^",2)=$P(SOPREC,"^",1) K ^MAGV(2005.64,"B",$P(SOPREC,"^",1),D0) "RTN","MAGDRPC9",64,0) . . S $P(SOPREC,"^",1)=OUT,^MAGV(2005.64,"B",OUT,D0)="" "RTN","MAGDRPC9",65,0) . . S ^MAGV(2005.64,D0,0)=SOPREC "RTN","MAGDRPC9",66,0) . . Q "RTN","MAGDRPC9",67,0) . L -^MAGV(2005.64,"B") "RTN","MAGDRPC9",68,0) . Q "RTN","MAGDRPC9",69,0) Q "RTN","MAGDRPC9",70,0) ; "RTN","MAGDRPC9",71,0) QRNEWUID(IMAGE,DBTYPE) ; Get updated UID for Query/Retrieve "RTN","MAGDRPC9",72,0) N DATE,DH,FAIL,I,OLD,OUT,NEW,LASTUID,NEXTUID,TIME,X,Y "RTN","MAGDRPC9",73,0) S DBTYPE=$G(DBTYPE,"OLD") "RTN","MAGDRPC9",74,0) S IMAGE=+$G(IMAGE) "RTN","MAGDRPC9",75,0) D:DBTYPE="OLD" ; find new UID, if any, in legacy DB "RTN","MAGDRPC9",76,0) . S NEW=$P($G(^MAG(2005,IMAGE,"SOP")),"^",2) "RTN","MAGDRPC9",77,0) . Q "RTN","MAGDRPC9",78,0) D:DBTYPE="NEW" ; find new UID, if any, in P34 DB "RTN","MAGDRPC9",79,0) . S NEW="" S:$P($G(^MAGV(2005.64,IMAGE,0)),"^",2)'="" NEW=$P(^(0),"^",1) "RTN","MAGDRPC9",80,0) . Q "RTN","MAGDRPC9",81,0) Q:NEW'="" NEW "RTN","MAGDRPC9",82,0) ; Generate the next UID using date/time and counter "RTN","MAGDRPC9",83,0) L +^MAGDICOM(2006.563,1,"MACHINE ID"):1E9 ; Background process must wait "RTN","MAGDRPC9",84,0) S LASTUID=$G(^MAGDICOM(2006.563,1,"LAST UID")) "RTN","MAGDRPC9",85,0) ; Can't use D NOW^XLFDT to set DH because it is incorrect at midnight "RTN","MAGDRPC9",86,0) S DH=$H,X=$$HTFM^XLFDT(DH,1),DATE=X+17000000 "RTN","MAGDRPC9",87,0) S X=$P(DH,",",2) D "RTN","MAGDRPC9",88,0) . N H,M,S "RTN","MAGDRPC9",89,0) . S H=X\3600,M=X\60#60,S=X#60 "RTN","MAGDRPC9",90,0) . S TIME=H*100+M*100+S "RTN","MAGDRPC9",91,0) . Q "RTN","MAGDRPC9",92,0) S NEXTUID=$G(^MAGD(2006.15,1,"UID ROOT")) "RTN","MAGDRPC9",93,0) I NEXTUID="" S $EC=",13:No UID Root defined - Run INIT^MAGDRUID," ; Fatal Error "RTN","MAGDRPC9",94,0) ; UID type = 7, Machine ID = 0 "RTN","MAGDRPC9",95,0) S NEXTUID=NEXTUID_".1.7."_(+$G(DUZ(2)))_".0."_DATE_"."_TIME_".0" "RTN","MAGDRPC9",96,0) ; Remove leading 0s from UID components "RTN","MAGDRPC9",97,0) F I=1:1:$L(NEXTUID,".") S $P(NEXTUID,".",I)=+$P(NEXTUID,".",I) "RTN","MAGDRPC9",98,0) I $P(NEXTUID,".",1,10)=$P(LASTUID,".",1,10) D "RTN","MAGDRPC9",99,0) . S NEXTUID=LASTUID "RTN","MAGDRPC9",100,0) . S $P(NEXTUID,".",11)=$P(NEXTUID,".",11)+1 "RTN","MAGDRPC9",101,0) . Q "RTN","MAGDRPC9",102,0) S ^MAGDICOM(2006.563,1,"LAST UID")=NEXTUID "RTN","MAGDRPC9",103,0) L -^MAGDICOM(2006.563,1,"MACHINE ID") "RTN","MAGDRPC9",104,0) S OLD=$S(DBTYPE="OLD":$P($G(^MAG(2005,IMAGE,"PACS")),"^",1),1:$P($G(^MAGV(2005.64,IMAGE,0)),"^",1)) "RTN","MAGDRPC9",105,0) D NEWUID(.OUT,OLD,NEXTUID,IMAGE,DBTYPE) ; Store the new UID with the image "RTN","MAGDRPC9",106,0) Q OUT "RTN","MAGDRPC9",107,0) ; "RTN","MAGDRPC9",108,0) NEXT(OUT,SEED,DIR) ; RPC = MAG RAD GET NEXT RPT BY DATE "RTN","MAGDRPC9",109,0) N D2,DFN,EXAMDATE,NAME "RTN","MAGDRPC9",110,0) ; "RTN","MAGDRPC9",111,0) ; ^RADPT(DFN,"DT",D1,"P",D2,0) = Data, $P(17) = pointer to report "RTN","MAGDRPC9",112,0) ; ^RADPT("AR",9999999.9999-D1,DFN,D1)="" ; IA # 65 "RTN","MAGDRPC9",113,0) ; "RTN","MAGDRPC9",114,0) ; OUT = report_pointer ^ ExamDate ^ Patient ^ D2 "RTN","MAGDRPC9",115,0) ; "RTN","MAGDRPC9",116,0) S SEED=$G(SEED),DIR=$S($G(DIR)<0:-1,1:1) ; default is ascending order "RTN","MAGDRPC9",117,0) S EXAMDATE=$P(SEED,"^",1),DFN=$P(SEED,"^",2),D2=$P(SEED,"^",3) "RTN","MAGDRPC9",118,0) S OUT=0 F D Q:OUT "RTN","MAGDRPC9",119,0) . I EXAMDATE="" S EXAMDATE=$O(^RADPT("AR",""),DIR),DFN="" ; IA # 65 "RTN","MAGDRPC9",120,0) . I EXAMDATE="" S OUT=-1 Q "RTN","MAGDRPC9",121,0) . I DFN="" S DFN=$O(^RADPT("AR",EXAMDATE,""),DIR) ; IA # 65 "RTN","MAGDRPC9",122,0) . I DFN="" S EXAMDATE=$O(^RADPT("AR",EXAMDATE),DIR),D2="" Q ; IA # 65 "RTN","MAGDRPC9",123,0) . S:'D2 D2=$S(DIR>0:0,1:" ") "RTN","MAGDRPC9",124,0) . S D2=$O(^RADPT(DFN,"DT",9999999.9999-EXAMDATE,"P",D2),DIR) ; IA # 1172 "RTN","MAGDRPC9",125,0) . I 'D2 D Q "RTN","MAGDRPC9",126,0) . . S DFN=$O(^RADPT("AR",EXAMDATE,DFN),DIR),D2="" ; IA # 65 "RTN","MAGDRPC9",127,0) . . I 'DFN D "RTN","MAGDRPC9",128,0) . . . S EXAMDATE=$O(^RADPT("AR",EXAMDATE),DIR),DFN="" ; IA # 65 "RTN","MAGDRPC9",129,0) . . . I EXAMDATE="" S OUT=-1 "RTN","MAGDRPC9",130,0) . . . Q "RTN","MAGDRPC9",131,0) . . Q "RTN","MAGDRPC9",132,0) . S OUT=$P($G(^RADPT(DFN,"DT",9999999.9999-EXAMDATE,"P",D2,0)),"^",17) ; IA # 1172 "RTN","MAGDRPC9",133,0) . S:OUT OUT=OUT_"^"_EXAMDATE_"^"_DFN_"^"_D2 "RTN","MAGDRPC9",134,0) . Q "RTN","MAGDRPC9",135,0) Q "RTN","MAGDRPC9",136,0) ; "RTN","MAGDRPC9",137,0) NXTPTRPT(OUT,DFN,RARPT1,DIR) ; RPC = MAG RAD GET NEXT RPT BY PT "RTN","MAGDRPC9",138,0) S DFN=$G(DFN) "RTN","MAGDRPC9",139,0) I 'DFN S OUT="-1,Patient DFN not passed" Q "RTN","MAGDRPC9",140,0) I '$D(^RARPT("C",DFN)) S OUT="-2,Patient does not have any radiology reports" Q ; IA # 2442 "RTN","MAGDRPC9",141,0) S RARPT1=$G(RARPT1),DIR=$S($G(DIR)<0:-1,1:1) ; default is ascending order "RTN","MAGDRPC9",142,0) S OUT=$O(^RARPT("C",DFN,RARPT1),DIR) ; IA # 2442 "RTN","MAGDRPC9",143,0) Q "RTN","MAGDRPC9",144,0) ; "RTN","MAGDRPC9",145,0) GETICN(OUT,DFN) ; RPC = MAG DICOM GET ICN "RTN","MAGDRPC9",146,0) S OUT=$S($T(GETICN^MPIF001)'="":$$GETICN^MPIF001(DFN),1:"-1^NO MPI") "RTN","MAGDRPC9",147,0) Q "RTN","MAGDRPC9",148,0) ; "RTN","MAGDRPC9",149,0) CLEAN ; Overflow from MAGDRPC4 "RTN","MAGDRPC9",150,0) ; P180 DAC - Moved global locking to calling routine MAGDRPC4 "RTN","MAGDRPC9",151,0) N REQUESTDATETIME,STUID,PRI,S0,S1,STS,NEWSTS "RTN","MAGDRPC9",152,0) S S0=$P(SENT(I),"^",1),S1=$P(SENT(I),"^",2),NEWSTS=$P(SENT(I),"^",3) "RTN","MAGDRPC9",153,0) Q:'$D(^MAGDOUTP(2006.574,S0,1,S1)) "RTN","MAGDRPC9",154,0) ; "RTN","MAGDRPC9",155,0) S X=$G(^MAGDOUTP(2006.574,S0,0)),LOC=$P(X,"^",4),PRI=+$P(X,"^",5) "RTN","MAGDRPC9",156,0) S REQUESTDATETIME=$P(X,"^",7) "RTN","MAGDRPC9",157,0) S STS=$P($G(^MAGDOUTP(2006.574,S0,1,S1,0)),"^",2) "RTN","MAGDRPC9",158,0) ; "RTN","MAGDRPC9",159,0) I NEWSTS'="" D Q ; just update the status and get out "RTN","MAGDRPC9",160,0) . S $P(^MAGDOUTP(2006.574,S0,1,S1,0),"^",2)=NEWSTS,$P(^(0),"^",3)=$H "RTN","MAGDRPC9",161,0) . I LOC'="",PRI'="" S ^MAGDOUTP(2006.574,"STS",LOC,PRI,NEWSTS,S0,S1)="" "RTN","MAGDRPC9",162,0) . I LOC'="",PRI'="",STS'="" K ^MAGDOUTP(2006.574,"STS",LOC,PRI,STS,S0,S1) "RTN","MAGDRPC9",163,0) . Q "RTN","MAGDRPC9",164,0) ; "RTN","MAGDRPC9",165,0) K ^MAGDOUTP(2006.574,S0,1,S1) "RTN","MAGDRPC9",166,0) I LOC'="",PRI'="",STS'="" K ^MAGDOUTP(2006.574,"STS",LOC,PRI,STS,S0,S1) "RTN","MAGDRPC9",167,0) S X=$G(^MAGDOUTP(2006.574,S0,1,0)) "RTN","MAGDRPC9",168,0) S $P(X,"^",4)=$P(X,"^",4)-1 "RTN","MAGDRPC9",169,0) S ^MAGDOUTP(2006.574,S0,1,0)=X "RTN","MAGDRPC9",170,0) ; "RTN","MAGDRPC9",171,0) Q:$O(^MAGDOUTP(2006.574,S0,1,0)) ; don't delete the study node yet "RTN","MAGDRPC9",172,0) ; "RTN","MAGDRPC9",173,0) S STUID=$G(^MAGDOUTP(2006.574,S0,2)) "RTN","MAGDRPC9",174,0) K ^MAGDOUTP(2006.574,S0) "RTN","MAGDRPC9",175,0) K:REQUESTDATETIME'="" ^MAGDOUTP(2006.574,"C",REQUESTDATETIME,S0) "RTN","MAGDRPC9",176,0) K:STUID'="" ^MAGDOUTP(2006.574,"STUDY",STUID) "RTN","MAGDRPC9",177,0) S X=$G(^MAGDOUTP(2006.574,0)) "RTN","MAGDRPC9",178,0) S $P(X,"^",4)=$P(X,"^",4)-1 "RTN","MAGDRPC9",179,0) S ^MAGDOUTP(2006.574,0)=X "RTN","MAGDRPC9",180,0) Q "RTN","MAGDRPC9",181,0) ; "RTN","MAGDRPC9",182,0) IENLOOK ; Overflow from MAGDRPC4 "RTN","MAGDRPC9",183,0) ; lookup image by the IEN "RTN","MAGDRPC9",184,0) N ACNUMB,D0,DFN,GROUPIEN,MODIFIER,P,PROCNAME,STUDYDAT,X,Y "RTN","MAGDRPC9",185,0) S NUMBER=+$P(NUMBER,"`",2) "RTN","MAGDRPC9",186,0) ; patient safety checks "RTN","MAGDRPC9",187,0) D CHK^MAGGSQI(.X,NUMBER) I +$G(X(0))'=1 D Q "RTN","MAGDRPC9",188,0) . S OUT(1)="-9,"_$P(X(0),"^",2,999) "RTN","MAGDRPC9",189,0) . Q "RTN","MAGDRPC9",190,0) S GROUPIEN=$P($G(^MAG(2005,NUMBER,0)),"^",10) "RTN","MAGDRPC9",191,0) I GROUPIEN D CHK^MAGGSQI(.X,GROUPIEN) I +$G(X(0))'=1 D Q "RTN","MAGDRPC9",192,0) . S OUT(1)="-10,Group #"_GROUPIEN_": "_$P(X(0),"^",2,999) "RTN","MAGDRPC9",193,0) . Q "RTN","MAGDRPC9",194,0) ; "RTN","MAGDRPC9",195,0) S X=$G(^MAG(2005,NUMBER,2)),P=$P(X,"^",6),D0=$P(X,"^",7) "RTN","MAGDRPC9",196,0) I 'P!'D0 D ; get parent from group "RTN","MAGDRPC9",197,0) . S:GROUPIEN X=$G(^MAG(2005,GROUPIEN,2)),P=$P(X,"^",6),D0=$P(X,"^",7) "RTN","MAGDRPC9",198,0) . Q "RTN","MAGDRPC9",199,0) ; "RTN","MAGDRPC9",200,0) S OUT(2)=P_"^"_D0_"^"_NUMBER_"^" ; result w/o Accession Number "RTN","MAGDRPC9",201,0) I 'P!'D0 S OUT(1)="-6,Warning - Parent file entry is not present - no Accession Number." "RTN","MAGDRPC9",202,0) E I P=74 D "RTN","MAGDRPC9",203,0) . N DATETIME,I,INFO,PROC,RADPT0,RADPT1,RADPT2,RADPT3,RARPT0 "RTN","MAGDRPC9",204,0) . S X=$$ACCRPT^RAAPI(D0,.INFO) "RTN","MAGDRPC9",205,0) . I X<0 S OUT(1)="-11,Radiology Problem: "_X Q "RTN","MAGDRPC9",206,0) . S ACNUMB=INFO(1) "RTN","MAGDRPC9",207,0) . S RARPT0=$G(^RARPT(D0,0)) ; IA # 1171 "RTN","MAGDRPC9",208,0) . S RADPT1=$P(RARPT0,"^",2),DATETIME=$P(RARPT0,"^",3) "RTN","MAGDRPC9",209,0) . S RADPT2=9999999.9999-DATETIME,RADPT3=1 "RTN","MAGDRPC9",210,0) . S RADPT0=$G(^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,0)) "RTN","MAGDRPC9",211,0) . S PROCNAME=$$GET1^DIQ(71,$P(RADPT0,"^",2),.01) "RTN","MAGDRPC9",212,0) . S STUDYDAT=17000000+(DATETIME\1) "RTN","MAGDRPC9",213,0) . S MODIFIER="" "RTN","MAGDRPC9",214,0) . S I=0 F S I=$O(^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,"M",I)) Q:'I D "RTN","MAGDRPC9",215,0) . . S X=^RADPT(RADPT1,"DT",RADPT2,"P",RADPT3,"M",I,0) "RTN","MAGDRPC9",216,0) . . S:I>1 MODIFIER=MODIFIER_", " S MODIFIER=MODIFIER_$$GET1^DIQ(71.2,X,.01) "RTN","MAGDRPC9",217,0) . . Q "RTN","MAGDRPC9",218,0) . S X=P_"^"_D0_"^"_NUMBER_"^"_ACNUMB_"^"_STUDYDAT_"^"_PROCNAME_"^"_MODIFIER "RTN","MAGDRPC9",219,0) . S OUT(1)=1,OUT(2)=X "RTN","MAGDRPC9",220,0) . Q "RTN","MAGDRPC9",221,0) E I P=8925 D "RTN","MAGDRPC9",222,0) . N GMRCIEN,LABINFO "RTN","MAGDRPC9",223,0) . ; get pointer from TIU to consult request "RTN","MAGDRPC9",224,0) . S X=$$GET1^DIQ(8925,D0,1405,"I") ; IA ??? "RTN","MAGDRPC9",225,0) . I $P(X,";",2)="GMR(123," D "RTN","MAGDRPC9",226,0) . . S GMRCIEN=$P(X,";"),ACNUMB=$$GMRCACN^MAGDFCNV(GMRCIEN) "RTN","MAGDRPC9",227,0) . . S STUDYDAT=17000000+($$GET1^DIQ(123,GMRCIEN,.01,"I")\1) "RTN","MAGDRPC9",228,0) . . S PROCNAME=$$GET1^DIQ(123,GMRCIEN,1) ; TO SERVICE "RTN","MAGDRPC9",229,0) . . S MODIFIER=$$GET1^DIQ(123,GMRCIEN,4) ; PROCEDURE "RTN","MAGDRPC9",230,0) . . S X=P_"^"_D0_"^"_NUMBER_"^"_ACNUMB_"^"_STUDYDAT_"^"_PROCNAME_"^"_MODIFIER "RTN","MAGDRPC9",231,0) . . S OUT(1)=1,OUT(2)=X "RTN","MAGDRPC9",232,0) . . Q "RTN","MAGDRPC9",233,0) . S X=$$GET1^DIQ(8925,D0,.04,"E") "RTN","MAGDRPC9",234,0) . I X="LR ANATOMIC PATHOLOGY" D "RTN","MAGDRPC9",235,0) . . D GETINFO(.LABINFO,D0) "RTN","MAGDRPC9",236,0) . . I $D(LABINFO) D "RTN","MAGDRPC9",237,0) . . S X=P_"^"_D0_"^"_NUMBER_"^"_LABINFO("ACNUMB") "RTN","MAGDRPC9",238,0) . . S X=X_"^"_LABINFO("DATE") "RTN","MAGDRPC9",239,0) . . S X=X_"^"_LABINFO("LAB")_"^" "RTN","MAGDRPC9",240,0) . . S OUT(1)=1,OUT(2)=X "RTN","MAGDRPC9",241,0) . . Q "RTN","MAGDRPC9",242,0) . E S OUT(1)="-8,Problem with parent file "_P_", internal entry number "_D0_" - no Accession Number." "RTN","MAGDRPC9",243,0) . Q "RTN","MAGDRPC9",244,0) E S OUT(1)="-7,Parent file "_P_" not yet supported - no Accession Number." "RTN","MAGDRPC9",245,0) Q "RTN","MAGDRPC9",246,0) ; "RTN","MAGDRPC9",247,0) GETINFO(INFO,TIUIEN) ; scan the TIU document and try to extract the accession number "RTN","MAGDRPC9",248,0) N FILE ; ---- LAB DATA subfile numbers and other info "RTN","MAGDRPC9",249,0) N ERRSTAT S ERRSTAT=0 ; error status - assume nothing to repor "RTN","MAGDRPC9",250,0) N ERROR,I,LRSS,IENS,TEXT,X "RTN","MAGDRPC9",251,0) S IENS=TIUIEN_"," "RTN","MAGDRPC9",252,0) D GETS^DIQ(8925,IENS,2,"I","TEXT","ERROR") "RTN","MAGDRPC9",253,0) F I=1:1 Q:'$D(TEXT(8925,IENS,2,I)) S X=TEXT(8925,IENS,2,I) D "RTN","MAGDRPC9",254,0) . I '$D(INFO("ACNUMB")),X["Accession No." D "RTN","MAGDRPC9",255,0) . . S INFO("ACNUMB")=$P(X,"Accession No. ",2) "RTN","MAGDRPC9",256,0) . . S LRSS=$E(INFO("ACNUMB"),1,2) "RTN","MAGDRPC9",257,0) . . S ERRSTAT=$$GETFILE^MAGT7MA(LRSS) I ERRSTAT S INFO("LAB")="" Q "RTN","MAGDRPC9",258,0) . . S INFO("LAB")=FILE("NAME") "RTN","MAGDRPC9",259,0) . . Q "RTN","MAGDRPC9",260,0) . I '$D(INFO("DATE")),X["Date obtained: " S INFO("DATE")=$P(X,"Date obtained: ",2) "RTN","MAGDRPC9",261,0) . Q "RTN","MAGDRPC9",262,0) Q "RTN","MAGIP180") 0^^B4110394 "RTN","MAGIP180",1,0) MAGIP180 ;WOIFO/DAC - Install code for MAG*3.0*180 ; 19 Sept 2017 10:05 AM "RTN","MAGIP180",2,0) ;;3.0;IMAGING;**180**;Mar 19, 2002;Build 16 "RTN","MAGIP180",3,0) ;; Per VHA Directive 2004-038, this routine should not be modified. "RTN","MAGIP180",4,0) ;; +---------------------------------------------------------------+ "RTN","MAGIP180",5,0) ;; | Property of the US Government. | "RTN","MAGIP180",6,0) ;; | No permission to copy or redistribute this software is given. | "RTN","MAGIP180",7,0) ;; | Use of unreleased versions of this software requires the user | "RTN","MAGIP180",8,0) ;; | to execute a written test agreement with the VistA Imaging | "RTN","MAGIP180",9,0) ;; | Development Office of the Department of Veterans Affairs, | "RTN","MAGIP180",10,0) ;; | telephone (301) 734-0100. | "RTN","MAGIP180",11,0) ;; | The Food and Drug Administration classifies this software as | "RTN","MAGIP180",12,0) ;; | a medical device. As such, it may not be changed in any way. | "RTN","MAGIP180",13,0) ;; | Modifications to this software may result in an adulterated | "RTN","MAGIP180",14,0) ;; | medical device under 21CFR820, the use of which is considered | "RTN","MAGIP180",15,0) ;; | to be a violation of US Federal Statutes. | "RTN","MAGIP180",16,0) ;; +---------------------------------------------------------------+ "RTN","MAGIP180",17,0) ;; "RTN","MAGIP180",18,0) ; There are no environment checks here but the MAGIP180 has to be "RTN","MAGIP180",19,0) ; referenced by the "Environment Check Routine" field of the KIDS "RTN","MAGIP180",20,0) ; build so that entry points of the routine are available to the "RTN","MAGIP180",21,0) ; KIDS during all installation phases. "RTN","MAGIP180",22,0) Q "RTN","MAGIP180",23,0) ; "RTN","MAGIP180",24,0) ;+++++ INSTALLATION ERROR HANDLING "RTN","MAGIP180",25,0) ERROR ; "RTN","MAGIP180",26,0) S:$D(XPDNM) XPDABORT=1 "RTN","MAGIP180",27,0) ;--- Display the messages and store them to the INSTALL file "RTN","MAGIP180",28,0) D DUMP^MAGUERR1(),ABTMSG^MAGKIDS() "RTN","MAGIP180",29,0) Q "RTN","MAGIP180",30,0) ; "RTN","MAGIP180",31,0) ;***** POST-INSTALL CODE "RTN","MAGIP180",32,0) POS ; "RTN","MAGIP180",33,0) N CALLBACK "RTN","MAGIP180",34,0) D CLEAR^MAGUERR(1) "RTN","MAGIP180",35,0) ; "RTN","MAGIP180",36,0) ;--- Send the notification e-mail "RTN","MAGIP180",37,0) D BMES^XPDUTL("Post Install Mail Message: "_$$FMTE^XLFDT($$NOW^XLFDT)) "RTN","MAGIP180",38,0) D INS^MAGQBUT4(XPDNM,DUZ,$$NOW^XLFDT,XPDA) "RTN","MAGIP180",39,0) Q "RTN","MAGIP180",40,0) ; "RTN","MAGIP180",41,0) ;***** PRE-INSTALL CODE "RTN","MAGIP180",42,0) PRE ; "RTN","MAGIP180",43,0) Q "VER") 8.0^22.2 **END** **END**