Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MDRPCOT1

MDRPCOT1.m

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