- MDRPCOT1 ;HOIFO/NCA/DP,WOIFO/PMK - Object RPCs (TMDTransaction) - Continued ;03 Jul 2018 9:09 AM
- ;;1.0;CLINICAL PROCEDURES;**5,11,21,41,60,78**;Apr 01, 2004;Build 7
- ; Integration Agreements:
- ; IA# 10000 [Supported] calls to NOW^%DTC
- ; IA# 2053 [Supported] calls to FILE^DIE
- ; IA# 10013 [Supported] calls to DIK
- ; IA# 2056 [Supported] calls to $$GET1^DIQ
- ; IA# 2056 [Supported] calls to GETS^DIQ
- ; IA# 3468 [Subscription] $$CPDOC^GMRCCP
- ; IA# 6931 [Private] call to $$GMRCACN^MAGDFCNV
- ; IA# 3567 [Subscription] IMPORT^MAGGSIUI
- ; IA# 10061 [Supported] Calls to IN5^VADPT
- ; IA# 10103 [Supported] Calls to $$NOW^XLFDT.
- ; IA# 5844 [Supported] Calls to $$CONVERT^XLFIPV
- ; IA# 2263 [Supported] calls to $$GET^XPAR and GETLST^XPAR
- ; IA# 3067 [Private] Reads fields in Consults file (#123).
- ; IA# 10040 [Supported] Hospital Location File Access
- ;
- ; 09/25/15 KAM Remedy Call 1095728 Patch MD*1*41 IPv6 modifications
- ;
- DELERR(MDTIEN) ; [Procedure] Delete Imaging Error Messages
- S MDLP=0 F S MDLP=$O(^MDD(702,MDTIEN,.091,MDLP)) Q:'MDLP D
- .K DA,DIK
- .S DA=+MDLP,DA(1)=+MDTIEN,DIK="^MDD(702,"_DA(1)_",.091," D ^DIK
- .Q
- Q
- ;
- IMGSTAT(STUDY,MDSTAT) ; [Procedure] Update the Image Status.
- N MDL
- S MDL=0 F S MDL=$O(^MDD(702,STUDY,.1,MDL)) Q:MDL<1 S $P(^(MDL,0),"^",9)=MDSTAT
- Q
- ;
- GETVSTR(DFN,MDSSTR,MDPR,MDTR) ; [Function] Check the Visit String
- N MDCLOC,MDHOLD,MDLOC,MDINPT,VAIP
- N MDPR12,MDAPP ; Patch 11
- I '$G(MDTR) Q 0
- I '$G(MDPR) Q 0
- I $G(MDSSTR)="" Q 0
- S VAIP("D")=MDTR ; DT of Transaction Created
- D IN5^VADPT S MDINPT=$S(+VAIP(13):1,1:0)
- S (MDCLOC,MDHOLD)=$$GET1^DIQ(702.01,+MDPR_",",.05,"I")
- ; Patch 11
- S MDPR12=$$GET1^DIQ(702.01,+MDPR_",",.12,"I")
- S:MDPR12=1 MDCLOC=""
- S MDAPP=$$GET^XPAR("SYS","MD USE APPOINTMENT",1)
- ; End Patch 11 code
- I 'MDCLOC S MDCLOC=+$P(MDSSTR,";",3) I 'MDCLOC S MDCLOC=MDHOLD I 'MDCLOC Q 0
- I +MDAPP S MDCLOC=$S(+$P(MDSSTR,";",3)>1:+$P(MDSSTR,";",3),1:MDCLOC) I 'MDCLOC Q 0
- S Y=MDCLOC_";"_$P(MDSSTR,";",2)_";"_$P(MDSSTR,";")
- I $P(Y,";",3)="A" Q Y
- S:$P(Y,";",3)="" $P(Y,";",3)="A"
- S:+MDINPT $P(Y,";",3)="A"
- S:$P(Y,";",3)="V" $P(Y,";",3)="A"
- Q Y
- ;
- PDT(STUDIE) ; [Function] Loop through the attachments for Date/Time Performed.
- N MDL,MDDT
- S MDL=0,MDDT=""
- F S MDL=$O(^MDD(702,STUDIE,.1,MDL)) Q:'MDL D Q:MDDT
- .S MDDT=$P($G(^MDD(702,STUDIE,.1,MDL,0)),"^",3)
- I MDDT S MDDT=$P($G(^MDD(703.1,+MDDT,0)),"^",3) ; Get Date/Time Performed
- ;S:'MDDT MDDT=$$NOW^XLFDT()
- Q MDDT
- ;
- SUBMIT(STUDY) ; [Function] Submit all non-pending/uncomplete images in transaction to Imaging
- N DATA,DEVIEN,MDACQ,MDC,MDCRES,MDCTR,MDLOC,MDAR,MDARR,MDDT,MDFDA,MDDEL,MDIEN,MDIENS,MDIMG,MDL,MDLPB,MDMAG,MDMULT,MDR,MDST,MDX,MDY,MDZ
- S MDIEN=+STUDY,MDIENS=MDIEN_",",MDLPB=0
- S DEVIEN=$P(^MDD(702,STUDY,0),U,11)
- ;
- ; 09/25/15 KAM Remedy Ticket 1095728 IPv6 modifications
- ; Changed next line to use API
- ;S:$$GET1^DIQ(702.09,DEVIEN_",",.14)="127.0.0.1" MDLPB=1
- S:$$CONVERT^XLFIPV($$GET1^DIQ(702.09,DEVIEN_",",.14))=$$CONVERT^XLFIPV("127.0.0.1") MDLPB=1
- ;
- S MDMULT=$$MULT(+MDIEN)
- S MDST=$$GET1^DIQ(702,MDIEN,.09,"I") ; I 'MDMULT&('MDLPB)&("13"[MDST) Q "-1^Study not in proper status"
- I MDMULT&(MDST=1) Q "-1^Study not in proper status"
- I MDMULT&(MDST=3) D STATUS^MDRPCOT(MDIENS,5,"")
- D DELERR(+MDIEN)
- I $$GET1^DIQ(702,MDIEN,.01)="" Q "-1^No Entry in file (#702)."
- D NOW^%DTC S MDDT=%
- S MDMAG("IDFN")=+$$GET1^DIQ(702,MDIEN,.01,"I")
- I 'MDMAG("IDFN") Q "-1^No Patient DFN."
- S MDMAG("PXPKG")=8925
- S MDMAG("PXIEN")=+$$GET1^DIQ(702,MDIEN,.06,"I")
- I 'MDMAG("PXIEN") Q "-1^No TIU IEN"
- I '$O(^MDD(702,MDIEN,.1,0)) D Q $S(+MDR<0:MDR,1:"3^Transaction Complete")
- .S MDC=$$GET1^DIQ(702,MDIEN,.05,"I")
- .S MDR=$$UPDCONS(MDC,MDMAG("PXIEN"))
- S MDMAG("STSCB")="ISTAT^MDAPI"
- S MDMAG("TRKID")="CP;"_MDIEN_"-"_MDDT
- S MDLOC=$$GET1^DIQ(702,MDIEN,.07,"I"),MDLOC=$P(MDLOC,";",3)
- I 'MDLOC Q "-1^No Hospital Location."
- S MDMAG("ACQS")=$S(+$$GET1^DIQ(44,MDLOC_",",3,"I"):+$$GET1^DIQ(44,MDLOC_",",3,"I"),1:+$G(DUZ(2)))
- S MDMAG("ACQL")=MDLOC
- S MDX=$$GET1^DIQ(702,MDIEN,.04,"I")
- S MDZ=$P(^MDS(702.01,+MDX,0),"^",1)
- S (MDACQ,MDX,MDDEL)="",MDCTR=0
- N MDTOT S MDTOT=$$GET1^DIQ(702,MDIENS,.991)
- S MDL=0 F S MDL=$O(^MDD(702,MDIEN,.1,MDL)) Q:MDL<1 S MDX=$G(^(MDL,0)) D
- .S:'MDDEL MDDEL=$P(MDX,"^",3)
- .S MDY=$G(^MDD(702,MDIEN,.1,MDL,.1)) Q:MDY=""
- .S:MDACQ="" MDACQ=$P($P(MDY,"\\",2),"\")
- .S:"12"[$P(MDX,"^",9) $P(MDX,"^",9)=""
- .I $P(MDX,"^",9)="" S MDCTR=MDCTR+1,MDARR(MDCTR)=MDY_"^"_MDZ_" image "_MDCTR_" out of "_MDTOT
- .Q
- I '$O(MDARR(0)) Q "-1^No UNC."
- S MDMAG("GDESC")=MDZ_" Result"
- I MDDEL S MDY=$P($G(^MDD(703.1,+MDDEL,0)),"^",3,4),MDMAG("PXDT")=$P(MDY,"^",1),MDY=+$P(MDY,"^",2),MDMAG("ACQD")=$P($G(^MDS(702.09,+MDY,0)),"^"),MDMAG("DFLG")=+$P($G(^MDS(702.09,+MDY,0)),"^",5)
- S:$G(MDMAG("ACQD"))="" MDMAG("ACQD")=MDACQ
- S:'$G(MDMAG("PXDT")) MDMAG("PXDT")=MDDT ; If no date, use NOW in MDDT
- S MDMAG("TRTYPE")="NEW"
- D IMPORT^MAGGSIUI(.MDIMG,.MDARR,.MDMAG)
- I '(+$G(MDIMG(0))) D Q "-1^"_$P(MDIMG(0),"^",2)
- .D IMGSTAT(+MDIENS,1)
- .F MDAR=0:0 S MDAR=$O(MDIMG(MDAR)) Q:'MDAR I $G(MDIMG(MDAR))'="" D
- ..S DATA("MESSAGE")=$$TRANS^MDAPI(MDIMG(MDAR)) D ADDMSG^MDRPCOT
- D IMGSTAT(+MDIENS,0)
- Q "1^Images Submitted"
- ;
- UPDCONS(MDC,MDDOC) ; [Function] Update Consults Procedure Status
- N MDCRES,MDKK,MDSDY,MDPDEF,MDF,MDH,MDX3,MDX4,MDXC,MDXD S (MDF,MDXD)=0,MDX4=""
- D GETLST^XPAR(.MDH,"SYS","MD GET HIGH VOLUME")
- S MDSDY=$O(^MDD(702,"ACON",MDC,""),-1) Q:'+MDSDY 1
- S MDPDEF=+$P($G(^MDD(702,+MDSDY,0)),"^",4) Q:'+MDPDEF 1
- F MDKK=0:0 S MDKK=$O(MDH(MDKK)) Q:MDKK<1 I $P($G(MDH(MDKK)),"^")=+MDPDEF S MDF=1 Q
- I $P($G(^MDS(702.01,+MDPDEF,0)),U,6)=2 Q 1
- D GETS^DIQ(123,MDC_",","50*","I","MDXC")
- S MDX3="" F S MDX3=$O(MDXC(123.03,MDX3)) Q:MDX3<1 S MDX4=$G(MDXC(123.03,MDX3,.01,"I")) I MDX4["TIU" S:+MDX4=+$P($G(^MDD(702,+MDSDY,0)),"^",6) MDXD=1 Q
- I +$P($G(^MDS(702.01,+MDPDEF,0)),U,10)!(+MDF) Q:+MDXD 1
- S MDCRES=$$CPDOC^GMRCCP(MDC,MDDOC,2)
- I '(+MDCRES) Q "-1^"_$P(MDCRES,"^",2)
- Q 1
- ;
- GETIORD(MDIEN) ; [Function] Return the Instrument order number for this study
- ; Called from instrument interface routines
- Q:'$D(^MDD(702,MDIEN,0))#2 -1 ; No such study
- Q:'$P(^MDD(702,MDIEN,0),U,12) $$NEWIORD(MDIEN) ; Create a new one
- Q $P(^MDD(702,MDIEN,0),U,12) ; Return the existing one
- ;
- NEWIORD(MDIEN) ; [Function] Generate & return new unique instrument order number
- ; Notice: will overwrite existing order number if it exists
- N MDFDA
- Q:'$D(^MDD(702,MDIEN,0))#2 -1 ; No such study
- L +^MDD(702,"AION"):15 E Q -1 ; Unable to lock and guarantee uniqueness
- F D Q:'$D(^MDD(702,"AION",X)) H 1 ; Loop until unique
- . S X=$$NOW^XLFDT() ; Current DateTime
- . S X=$TR($J(X,14,6),".","") ; Pad with 0's and strip the decimal
- . Q
- I $E($G(^MDS(702.09,DEVIEN,0)),1,4)="Muse" D
- . ; Due to current limitation to the Muse can only except 9
- . ;MD*1.0*78 MUST RETURN EXACTLY 9 DIGITS 24 hours a day
- . ;S X=$E($TR($H,",",""),2,10) ; Using $E($H) only for the MUSE
- . ;MD*1.0*78 Add leading zeros to time to always create 9 digit order number
- . S X=$E($P($H,","),2,5)_$E("00000",1,5-$L($P($H,",",2)))_$P($H,",",2)
- . I '$D(^MDD(702,"AION",X)) Q ; It is unique and quit
- . N I,FLG ; Not unique
- . S FLG=0
- . F I=1:1 D Q:FLG
- . . S X=X+1
- . . I '$D(^MDD(702,"AION",X)) S FLG=1
- . . Q
- . Q
- S MDFDA(702,MDIEN_",",.12)=X ; Build FDA
- D FILE^DIE("","MDFDA") ; File it
- L -(^MDD(702,"AION")) ; Unlock it
- ;
- ; MD*1.0*60 - 25 April 2018 - Peter Kuzmak, VistA Imaging
- ; VistA Imaging code to replace the CP Instrument Order Number
- ; with the VistA Imaging consult Accession Number.
- ;
- ; This greatly improves interoperability between Clinical Procedure
- ; and VistA Imaging CPRS Consult Request Tracking DICOM because
- ; it allows DICOM objects created during a Clinical Procedure
- ; examination to be automatically associated in VistA.
- ;
- N MDS70209,MDFDA,MDGMRCIEN,MDIORD,MDCPDICOM
- S MDS70209=$$GET1^DIQ(702,MDD702,.11,"I") ; get instrument
- S MDCPDICOM=$$GET1^DIQ(702.09,MDS70209,.19,"I") ; get CP - DICOM Interoperability
- I MDCPDICOM D ; replace CP's accession number with VistA's
- . S MDGMRCIEN=$P(^MDD(702,MDIEN,0),U,5) ; consult number
- . S MDIORD=$$GMRCACN^MAGDFCNV(MDGMRCIEN) ; VI accession number
- . S MDFDA(702,MDIEN_",",.12)=MDIORD ; Build FDA
- . D FILE^DIE("","MDFDA") ; File it
- . Q
- ;
- Q $P(^MDD(702,MDIEN,0),U,12) ; Return it from the file
- ;
- GETSTDY(MDION) ; [Function] Return study from instrument order number
- ; Called from instrument interface routines
- Q:'$D(^MDD(702,"AION",MDION)) "" ; No such order number
- ;
- ; KLM/MD*1.0*60 - 27 June 2018
- ; Return the most recent transaction. We will look for a pending status on finals,
- ; and complete status on amendments. Failing that, return the most recent no matter
- ; what status as CP will check the transaction status later.
- ; Expected variable X contains the OBR segment
- ; If DEVIEN is not defined, or not using CP-VI accession number, get ION the old way
- I '$G(DEVIEN)!($$GET1^DIQ(702.09,DEVIEN,.19,"I")<1) Q $O(^MDD(702,"AION",MDION,""),-1) ; Return the 702 ien
- ;
- N MDQ,MDIEN,MDTST,MD25,MDX,MDS
- S MD25=$P($G(X),"|",26) ; OBR-25 Result status (CP uses F,C,X only)
- S (MDX,MDS,MDQ)=0
- S MDIEN="" F Q:MDQ S MDIEN=$O(^MDD(702,"AION",MDION,MDIEN),-1) Q:MDIEN="" D
- . S MDX=MDX+1 I MDX=1 S MDS=MDIEN ;save off first one
- . S MDTST=$P($G(^MDD(702,MDIEN,0)),U,9) ; Transaction Status
- . I MDTST=5,MD25="F" S MDQ=MDIEN ; check if status is 'Pending Instrument Data' for Final
- . I MDTST=3,MD25="C" S MDQ=MDIEN ; check if status is 'Complete' for Amendment
- . Q
- I MDQ=0,MDS S MDQ=MDS
- Q $S(MDQ>0:MDQ,1:"")
- ;
- MULT(MDIN) ; [Function] Return whether result is multiple or final
- N MDDEF
- S MDDEF=+$$GET1^DIQ(702,MDIN,.04,"I")
- I 'MDDEF Q 0
- Q +$$GET1^DIQ(702.01,MDDEF,.12,"I")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDRPCOT1 9905 printed Feb 18, 2025@23:10:32 Page 2
- MDRPCOT1 ;HOIFO/NCA/DP,WOIFO/PMK - Object RPCs (TMDTransaction) - Continued ;03 Jul 2018 9:09 AM
- +1 ;;1.0;CLINICAL PROCEDURES;**5,11,21,41,60,78**;Apr 01, 2004;Build 7
- +2 ; Integration Agreements:
- +3 ; IA# 10000 [Supported] calls to NOW^%DTC
- +4 ; IA# 2053 [Supported] calls to FILE^DIE
- +5 ; IA# 10013 [Supported] calls to DIK
- +6 ; IA# 2056 [Supported] calls to $$GET1^DIQ
- +7 ; IA# 2056 [Supported] calls to GETS^DIQ
- +8 ; IA# 3468 [Subscription] $$CPDOC^GMRCCP
- +9 ; IA# 6931 [Private] call to $$GMRCACN^MAGDFCNV
- +10 ; IA# 3567 [Subscription] IMPORT^MAGGSIUI
- +11 ; IA# 10061 [Supported] Calls to IN5^VADPT
- +12 ; IA# 10103 [Supported] Calls to $$NOW^XLFDT.
- +13 ; IA# 5844 [Supported] Calls to $$CONVERT^XLFIPV
- +14 ; IA# 2263 [Supported] calls to $$GET^XPAR and GETLST^XPAR
- +15 ; IA# 3067 [Private] Reads fields in Consults file (#123).
- +16 ; IA# 10040 [Supported] Hospital Location File Access
- +17 ;
- +18 ; 09/25/15 KAM Remedy Call 1095728 Patch MD*1*41 IPv6 modifications
- +19 ;
- DELERR(MDTIEN) ; [Procedure] Delete Imaging Error Messages
- +1 SET MDLP=0
- FOR
- SET MDLP=$ORDER(^MDD(702,MDTIEN,.091,MDLP))
- if 'MDLP
- QUIT
- Begin DoDot:1
- +2 KILL DA,DIK
- +3 SET DA=+MDLP
- SET DA(1)=+MDTIEN
- SET DIK="^MDD(702,"_DA(1)_",.091,"
- DO ^DIK
- +4 QUIT
- End DoDot:1
- +5 QUIT
- +6 ;
- IMGSTAT(STUDY,MDSTAT) ; [Procedure] Update the Image Status.
- +1 NEW MDL
- +2 SET MDL=0
- FOR
- SET MDL=$ORDER(^MDD(702,STUDY,.1,MDL))
- if MDL<1
- QUIT
- SET $PIECE(^(MDL,0),"^",9)=MDSTAT
- +3 QUIT
- +4 ;
- GETVSTR(DFN,MDSSTR,MDPR,MDTR) ; [Function] Check the Visit String
- +1 NEW MDCLOC,MDHOLD,MDLOC,MDINPT,VAIP
- +2 ; Patch 11
- NEW MDPR12,MDAPP
- +3 IF '$GET(MDTR)
- QUIT 0
- +4 IF '$GET(MDPR)
- QUIT 0
- +5 IF $GET(MDSSTR)=""
- QUIT 0
- +6 ; DT of Transaction Created
- SET VAIP("D")=MDTR
- +7 DO IN5^VADPT
- SET MDINPT=$SELECT(+VAIP(13):1,1:0)
- +8 SET (MDCLOC,MDHOLD)=$$GET1^DIQ(702.01,+MDPR_",",.05,"I")
- +9 ; Patch 11
- +10 SET MDPR12=$$GET1^DIQ(702.01,+MDPR_",",.12,"I")
- +11 if MDPR12=1
- SET MDCLOC=""
- +12 SET MDAPP=$$GET^XPAR("SYS","MD USE APPOINTMENT",1)
- +13 ; End Patch 11 code
- +14 IF 'MDCLOC
- SET MDCLOC=+$PIECE(MDSSTR,";",3)
- IF 'MDCLOC
- SET MDCLOC=MDHOLD
- IF 'MDCLOC
- QUIT 0
- +15 IF +MDAPP
- SET MDCLOC=$SELECT(+$PIECE(MDSSTR,";",3)>1:+$PIECE(MDSSTR,";",3),1:MDCLOC)
- IF 'MDCLOC
- QUIT 0
- +16 SET Y=MDCLOC_";"_$PIECE(MDSSTR,";",2)_";"_$PIECE(MDSSTR,";")
- +17 IF $PIECE(Y,";",3)="A"
- QUIT Y
- +18 if $PIECE(Y,";",3)=""
- SET $PIECE(Y,";",3)="A"
- +19 if +MDINPT
- SET $PIECE(Y,";",3)="A"
- +20 if $PIECE(Y,";",3)="V"
- SET $PIECE(Y,";",3)="A"
- +21 QUIT Y
- +22 ;
- PDT(STUDIE) ; [Function] Loop through the attachments for Date/Time Performed.
- +1 NEW MDL,MDDT
- +2 SET MDL=0
- SET MDDT=""
- +3 FOR
- SET MDL=$ORDER(^MDD(702,STUDIE,.1,MDL))
- if 'MDL
- QUIT
- Begin DoDot:1
- +4 SET MDDT=$PIECE($GET(^MDD(702,STUDIE,.1,MDL,0)),"^",3)
- End DoDot:1
- if MDDT
- QUIT
- +5 ; Get Date/Time Performed
- IF MDDT
- SET MDDT=$PIECE($GET(^MDD(703.1,+MDDT,0)),"^",3)
- +6 ;S:'MDDT MDDT=$$NOW^XLFDT()
- +7 QUIT MDDT
- +8 ;
- SUBMIT(STUDY) ; [Function] Submit all non-pending/uncomplete images in transaction to Imaging
- +1 NEW DATA,DEVIEN,MDACQ,MDC,MDCRES,MDCTR,MDLOC,MDAR,MDARR,MDDT,MDFDA,MDDEL,MDIEN,MDIENS,MDIMG,MDL,MDLPB,MDMAG,MDMULT,MDR,MDST,MDX,MDY,MDZ
- +2 SET MDIEN=+STUDY
- SET MDIENS=MDIEN_","
- SET MDLPB=0
- +3 SET DEVIEN=$PIECE(^MDD(702,STUDY,0),U,11)
- +4 ;
- +5 ; 09/25/15 KAM Remedy Ticket 1095728 IPv6 modifications
- +6 ; Changed next line to use API
- +7 ;S:$$GET1^DIQ(702.09,DEVIEN_",",.14)="127.0.0.1" MDLPB=1
- +8 if $$CONVERT^XLFIPV($$GET1^DIQ(702.09,DEVIEN_",",.14))=$$CONVERT^XLFIPV("127.0.0.1")
- SET MDLPB=1
- +9 ;
- +10 SET MDMULT=$$MULT(+MDIEN)
- +11 ; I 'MDMULT&('MDLPB)&("13"[MDST) Q "-1^Study not in proper status"
- SET MDST=$$GET1^DIQ(702,MDIEN,.09,"I")
- +12 IF MDMULT&(MDST=1)
- QUIT "-1^Study not in proper status"
- +13 IF MDMULT&(MDST=3)
- DO STATUS^MDRPCOT(MDIENS,5,"")
- +14 DO DELERR(+MDIEN)
- +15 IF $$GET1^DIQ(702,MDIEN,.01)=""
- QUIT "-1^No Entry in file (#702)."
- +16 DO NOW^%DTC
- SET MDDT=%
- +17 SET MDMAG("IDFN")=+$$GET1^DIQ(702,MDIEN,.01,"I")
- +18 IF 'MDMAG("IDFN")
- QUIT "-1^No Patient DFN."
- +19 SET MDMAG("PXPKG")=8925
- +20 SET MDMAG("PXIEN")=+$$GET1^DIQ(702,MDIEN,.06,"I")
- +21 IF 'MDMAG("PXIEN")
- QUIT "-1^No TIU IEN"
- +22 IF '$ORDER(^MDD(702,MDIEN,.1,0))
- Begin DoDot:1
- +23 SET MDC=$$GET1^DIQ(702,MDIEN,.05,"I")
- +24 SET MDR=$$UPDCONS(MDC,MDMAG("PXIEN"))
- End DoDot:1
- QUIT $SELECT(+MDR<0:MDR,1:"3^Transaction Complete")
- +25 SET MDMAG("STSCB")="ISTAT^MDAPI"
- +26 SET MDMAG("TRKID")="CP;"_MDIEN_"-"_MDDT
- +27 SET MDLOC=$$GET1^DIQ(702,MDIEN,.07,"I")
- SET MDLOC=$PIECE(MDLOC,";",3)
- +28 IF 'MDLOC
- QUIT "-1^No Hospital Location."
- +29 SET MDMAG("ACQS")=$SELECT(+$$GET1^DIQ(44,MDLOC_",",3,"I"):+$$GET1^DIQ(44,MDLOC_",",3,"I"),1:+$GET(DUZ(2)))
- +30 SET MDMAG("ACQL")=MDLOC
- +31 SET MDX=$$GET1^DIQ(702,MDIEN,.04,"I")
- +32 SET MDZ=$PIECE(^MDS(702.01,+MDX,0),"^",1)
- +33 SET (MDACQ,MDX,MDDEL)=""
- SET MDCTR=0
- +34 NEW MDTOT
- SET MDTOT=$$GET1^DIQ(702,MDIENS,.991)
- +35 SET MDL=0
- FOR
- SET MDL=$ORDER(^MDD(702,MDIEN,.1,MDL))
- if MDL<1
- QUIT
- SET MDX=$GET(^(MDL,0))
- Begin DoDot:1
- +36 if 'MDDEL
- SET MDDEL=$PIECE(MDX,"^",3)
- +37 SET MDY=$GET(^MDD(702,MDIEN,.1,MDL,.1))
- if MDY=""
- QUIT
- +38 if MDACQ=""
- SET MDACQ=$PIECE($PIECE(MDY,"\\",2),"\")
- +39 if "12"[$PIECE(MDX,"^",9)
- SET $PIECE(MDX,"^",9)=""
- +40 IF $PIECE(MDX,"^",9)=""
- SET MDCTR=MDCTR+1
- SET MDARR(MDCTR)=MDY_"^"_MDZ_" image "_MDCTR_" out of "_MDTOT
- +41 QUIT
- End DoDot:1
- +42 IF '$ORDER(MDARR(0))
- QUIT "-1^No UNC."
- +43 SET MDMAG("GDESC")=MDZ_" Result"
- +44 IF MDDEL
- SET MDY=$PIECE($GET(^MDD(703.1,+MDDEL,0)),"^",3,4)
- SET MDMAG("PXDT")=$PIECE(MDY,"^",1)
- SET MDY=+$PIECE(MDY,"^",2)
- SET MDMAG("ACQD")=$PIECE($GET(^MDS(702.09,+MDY,0)),"^")
- SET MDMAG("DFLG")=+$PIECE($GET(^MDS(702.09,+MDY,0)),"^",5)
- +45 if $GET(MDMAG("ACQD"))=""
- SET MDMAG("ACQD")=MDACQ
- +46 ; If no date, use NOW in MDDT
- if '$GET(MDMAG("PXDT"))
- SET MDMAG("PXDT")=MDDT
- +47 SET MDMAG("TRTYPE")="NEW"
- +48 DO IMPORT^MAGGSIUI(.MDIMG,.MDARR,.MDMAG)
- +49 IF '(+$GET(MDIMG(0)))
- Begin DoDot:1
- +50 DO IMGSTAT(+MDIENS,1)
- +51 FOR MDAR=0:0
- SET MDAR=$ORDER(MDIMG(MDAR))
- if 'MDAR
- QUIT
- IF $GET(MDIMG(MDAR))'=""
- Begin DoDot:2
- +52 SET DATA("MESSAGE")=$$TRANS^MDAPI(MDIMG(MDAR))
- DO ADDMSG^MDRPCOT
- End DoDot:2
- End DoDot:1
- QUIT "-1^"_$PIECE(MDIMG(0),"^",2)
- +53 DO IMGSTAT(+MDIENS,0)
- +54 QUIT "1^Images Submitted"
- +55 ;
- UPDCONS(MDC,MDDOC) ; [Function] Update Consults Procedure Status
- +1 NEW MDCRES,MDKK,MDSDY,MDPDEF,MDF,MDH,MDX3,MDX4,MDXC,MDXD
- SET (MDF,MDXD)=0
- SET MDX4=""
- +2 DO GETLST^XPAR(.MDH,"SYS","MD GET HIGH VOLUME")
- +3 SET MDSDY=$ORDER(^MDD(702,"ACON",MDC,""),-1)
- if '+MDSDY
- QUIT 1
- +4 SET MDPDEF=+$PIECE($GET(^MDD(702,+MDSDY,0)),"^",4)
- if '+MDPDEF
- QUIT 1
- +5 FOR MDKK=0:0
- SET MDKK=$ORDER(MDH(MDKK))
- if MDKK<1
- QUIT
- IF $PIECE($GET(MDH(MDKK)),"^")=+MDPDEF
- SET MDF=1
- QUIT
- +6 IF $PIECE($GET(^MDS(702.01,+MDPDEF,0)),U,6)=2
- QUIT 1
- +7 DO GETS^DIQ(123,MDC_",","50*","I","MDXC")
- +8 SET MDX3=""
- FOR
- SET MDX3=$ORDER(MDXC(123.03,MDX3))
- if MDX3<1
- QUIT
- SET MDX4=$GET(MDXC(123.03,MDX3,.01,"I"))
- IF MDX4["TIU"
- if +MDX4=+$PIECE($GET(^MDD(702,+MDSDY,0)),"^",6)
- SET MDXD=1
- QUIT
- +9 IF +$PIECE($GET(^MDS(702.01,+MDPDEF,0)),U,10)!(+MDF)
- if +MDXD
- QUIT 1
- +10 SET MDCRES=$$CPDOC^GMRCCP(MDC,MDDOC,2)
- +11 IF '(+MDCRES)
- QUIT "-1^"_$PIECE(MDCRES,"^",2)
- +12 QUIT 1
- +13 ;
- GETIORD(MDIEN) ; [Function] Return the Instrument order number for this study
- +1 ; Called from instrument interface routines
- +2 ; No such study
- if '$DATA(^MDD(702,MDIEN,0))#2
- QUIT -1
- +3 ; Create a new one
- if '$PIECE(^MDD(702,MDIEN,0),U,12)
- QUIT $$NEWIORD(MDIEN)
- +4 ; Return the existing one
- QUIT $PIECE(^MDD(702,MDIEN,0),U,12)
- +5 ;
- NEWIORD(MDIEN) ; [Function] Generate & return new unique instrument order number
- +1 ; Notice: will overwrite existing order number if it exists
- +2 NEW MDFDA
- +3 ; No such study
- if '$DATA(^MDD(702,MDIEN,0))#2
- QUIT -1
- +4 ; Unable to lock and guarantee uniqueness
- LOCK +^MDD(702,"AION"):15
- IF '$TEST
- QUIT -1
- +5 ; Loop until unique
- FOR
- Begin DoDot:1
- +6 ; Current DateTime
- SET X=$$NOW^XLFDT()
- +7 ; Pad with 0's and strip the decimal
- SET X=$TRANSLATE($JUSTIFY(X,14,6),".","")
- +8 QUIT
- End DoDot:1
- if '$DATA(^MDD(702,"AION",X))
- QUIT
- HANG 1
- +9 IF $EXTRACT($GET(^MDS(702.09,DEVIEN,0)),1,4)="Muse"
- Begin DoDot:1
- +10 ; Due to current limitation to the Muse can only except 9
- +11 ;MD*1.0*78 MUST RETURN EXACTLY 9 DIGITS 24 hours a day
- +12 ;S X=$E($TR($H,",",""),2,10) ; Using $E($H) only for the MUSE
- +13 ;MD*1.0*78 Add leading zeros to time to always create 9 digit order number
- +14 SET X=$EXTRACT($PIECE($HOROLOG,","),2,5)_$EXTRACT("00000",1,5-$LENGTH($PIECE($HOROLOG,",",2)))_$PIECE($HOROLOG,",",2)
- +15 ; It is unique and quit
- IF '$DATA(^MDD(702,"AION",X))
- QUIT
- +16 ; Not unique
- NEW I,FLG
- +17 SET FLG=0
- +18 FOR I=1:1
- Begin DoDot:2
- +19 SET X=X+1
- +20 IF '$DATA(^MDD(702,"AION",X))
- SET FLG=1
- +21 QUIT
- End DoDot:2
- if FLG
- QUIT
- +22 QUIT
- End DoDot:1
- +23 ; Build FDA
- SET MDFDA(702,MDIEN_",",.12)=X
- +24 ; File it
- DO FILE^DIE("","MDFDA")
- +25 ; Unlock it
- LOCK -(^MDD(702,"AION"))
- +26 ;
- +27 ; MD*1.0*60 - 25 April 2018 - Peter Kuzmak, VistA Imaging
- +28 ; VistA Imaging code to replace the CP Instrument Order Number
- +29 ; with the VistA Imaging consult Accession Number.
- +30 ;
- +31 ; This greatly improves interoperability between Clinical Procedure
- +32 ; and VistA Imaging CPRS Consult Request Tracking DICOM because
- +33 ; it allows DICOM objects created during a Clinical Procedure
- +34 ; examination to be automatically associated in VistA.
- +35 ;
- +36 NEW MDS70209,MDFDA,MDGMRCIEN,MDIORD,MDCPDICOM
- +37 ; get instrument
- SET MDS70209=$$GET1^DIQ(702,MDD702,.11,"I")
- +38 ; get CP - DICOM Interoperability
- SET MDCPDICOM=$$GET1^DIQ(702.09,MDS70209,.19,"I")
- +39 ; replace CP's accession number with VistA's
- IF MDCPDICOM
- Begin DoDot:1
- +40 ; consult number
- SET MDGMRCIEN=$PIECE(^MDD(702,MDIEN,0),U,5)
- +41 ; VI accession number
- SET MDIORD=$$GMRCACN^MAGDFCNV(MDGMRCIEN)
- +42 ; Build FDA
- SET MDFDA(702,MDIEN_",",.12)=MDIORD
- +43 ; File it
- DO FILE^DIE("","MDFDA")
- +44 QUIT
- End DoDot:1
- +45 ;
- +46 ; Return it from the file
- QUIT $PIECE(^MDD(702,MDIEN,0),U,12)
- +47 ;
- GETSTDY(MDION) ; [Function] Return study from instrument order number
- +1 ; Called from instrument interface routines
- +2 ; No such order number
- if '$DATA(^MDD(702,"AION",MDION))
- QUIT ""
- +3 ;
- +4 ; KLM/MD*1.0*60 - 27 June 2018
- +5 ; Return the most recent transaction. We will look for a pending status on finals,
- +6 ; and complete status on amendments. Failing that, return the most recent no matter
- +7 ; what status as CP will check the transaction status later.
- +8 ; Expected variable X contains the OBR segment
- +9 ; If DEVIEN is not defined, or not using CP-VI accession number, get ION the old way
- +10 ; Return the 702 ien
- IF '$GET(DEVIEN)!($$GET1^DIQ(702.09,DEVIEN,.19,"I")<1)
- QUIT $ORDER(^MDD(702,"AION",MDION,""),-1)
- +11 ;
- +12 NEW MDQ,MDIEN,MDTST,MD25,MDX,MDS
- +13 ; OBR-25 Result status (CP uses F,C,X only)
- SET MD25=$PIECE($GET(X),"|",26)
- +14 SET (MDX,MDS,MDQ)=0
- +15 SET MDIEN=""
- FOR
- if MDQ
- QUIT
- SET MDIEN=$ORDER(^MDD(702,"AION",MDION,MDIEN),-1)
- if MDIEN=""
- QUIT
- Begin DoDot:1
- +16 ;save off first one
- SET MDX=MDX+1
- IF MDX=1
- SET MDS=MDIEN
- +17 ; Transaction Status
- SET MDTST=$PIECE($GET(^MDD(702,MDIEN,0)),U,9)
- +18 ; check if status is 'Pending Instrument Data' for Final
- IF MDTST=5
- IF MD25="F"
- SET MDQ=MDIEN
- +19 ; check if status is 'Complete' for Amendment
- IF MDTST=3
- IF MD25="C"
- SET MDQ=MDIEN
- +20 QUIT
- End DoDot:1
- +21 IF MDQ=0
- IF MDS
- SET MDQ=MDS
- +22 QUIT $SELECT(MDQ>0:MDQ,1:"")
- +23 ;
- MULT(MDIN) ; [Function] Return whether result is multiple or final
- +1 NEW MDDEF
- +2 SET MDDEF=+$$GET1^DIQ(702,MDIN,.04,"I")
- +3 IF 'MDDEF
- QUIT 0
- +4 QUIT +$$GET1^DIQ(702.01,MDDEF,.12,"I")