MDWOR ; HOIFO/NCA - Main Routine to Decode HL7 ; 1/29/19 4:55pm
;;1.0;CLINICAL PROCEDURES;**14,11,21,20,37,42,54,69**;Apr 01,2004;Build 2
; Reference IA# 2263 [Supported] XPAR calls
; 3468 [Subscription] Call GMRCCP.
; 3071 [Subscription] Call $$PKGID^ORX8.
; 10035 [Supported] Access DPT("B"
; 10040 [Supported] Access SC(
; 10061 [Supported] VADPT call
; 10103 [Supported] XLFDT calls
; 03/18/2014 KAM MD*1*37 Rem Ticket 451758 Auto Check-in issue
EN(MDMSG) ; Entry Point for CPRS and pass MSG in MDMSG
N DFN,MDCON,MDCPROC,MDCANC,MDCANR,MDFN,MDIFN,MDINST,MDFLG,MDINT,MDL,MDIN,MDINP,MDINST,MDLOC,MDNAM,MDOBC,MDOBX,MDOPRO,MDPROC,MDPAT
N MDLL,MDK1,MDPROV,MDREQ,MDQTIM,MDROOT,MDRR,MDSINP,MDVSTD,MDX S MDVSTD=""
S (MDFLG,MDINP,MDINST,MDCANC,MDOBC)=0 F MDL=0:0 S MDL=$O(MDMSG(MDL)) Q:MDL<1!(+MDFLG>0) S MDX=$G(MDMSG(MDL)) D
.I $E(MDX,1,3)="MSH" D MSH Q
.I $E(MDX,1,3)="PID" D PID Q
.I $E(MDX,1,3)="PV1" D PV1 Q
.I $E(MDX,1,3)="ORC" D ORC Q
.I $E(MDX,1,3)="OBR" D OBR Q
.I $E(MDX,1,3)="OBX" D:MDOBC<1 OBX Q
.Q
D GETLST^XPAR(.MDLL,"SYS","MD CLINIC ASSOCIATION")
I +MDFLG<1&(+MDCANC<1)&(MDVSTD="") F MDK1=0:0 S MDK1=$O(MDLL(MDK1)) Q:MDK1<1 S MDROOT=$G(MDLL(MDK1)) I +$P(MDROOT,";",2)=MDPROC D Q:+MDRR
.S MDRR=0,MDIFN=MDFN,MDRR=$$GETAPPT(MDIFN,+$P(MDROOT,"^",2))
.S:+MDRR MDVSTD="A"_";"_$P(MDRR,"^",1)_";"_+$P(MDROOT,"^",2)
I +MDFLG<1&(MDVSTD'="") F MDK1=0:0 S MDK1=$O(MDLL(MDK1)) Q:MDK1<1 S MDROOT=$P($G(MDLL(MDK1)),"^",2) I +$P(MDROOT,";",2)=MDPROC D
.I +$P(MDVSTD,";",3)>0&(+MDROOT=$P(MDVSTD,";",3)) S MDFLG=0 Q
;
; 03/18/2014 KAM MD*1*37 Rem Ticket 451758
; Commented out the next line - setting the MDFLG to 1 on a clinic
; change is not needed
;.I +$P(MDVSTD,";",3)>0&(+MDROOT'=$P(MDVSTD,";",3)) S MDFLG=1 Q
;
I +MDFLG<1&(+MDCANC<1) S MDATA="+1,^"_MDPROC_"^"_+MDCON_"^"_MDINST_"^"_MDVSTD D CHKIN(MDFN,MDREQ,MDPROV,MDATA,MDVSTD)
Q
MSH ; Decode MSH
I $P(MDX,"|",2)'="^~\&" S MDFLG=1 Q
I $P(MDX,"|",3)'="ORDER ENTRY" S MDFLG=1 Q
I $P(MDX,"|",9)'="ORM" S MDFLG=1 Q
Q
PID ; Check PID
S MDNAM=$P(MDX,"|",6),DFN=$P(MDX,"|",4)
I '$D(^DPT("B",$E(MDNAM,1,30),DFN)) S MDFLG=1
S MDFN=DFN
Q
PV1 ; Check PV1
S MDPAT=$P(MDX,"|",3) I MDPAT'?1U!("IO"'[MDPAT) S MDFLG=1 Q
I MDPAT="I" S MDINP=1
S MDLOC=+$P(MDX,"|",4) I $G(^SC(MDLOC,0))="" S MDFLG=1 Q
S:MDINP>0 MDLOC=""
Q
ORC ; Check ORC
I $P(MDX,"|",2)="NW" D NEW Q
I $P(MDX,"|",2)="DC" D CANCEL Q
S MDFLG=1
Q
OBX ; Check OBX
N %,ANSWER,MDCV,MDOBX
S MDOBX=$P(MDX,"|",6)
I '+$$GET^XPAR("SYS","MD USE APPT WITH PROCEDURE",1) S MDOBC=MDOBC+1 Q
S MDVSTD=$P(MDOBX,"Visit Date: ",2)
S MDCV=$P(MDVSTD," ",1,2)
I MDCV=""!(MDCV["UNKNOWN") S MDFLG=1 Q
S MDVSTD=$P(MDCV," ")_"@"_$P(MDCV," ",2)
D DT^DILF("T",MDVSTD,.ANSWER)
S:ANSWER<0 ANSWER=""
S MDVSTD=ANSWER I MDVSTD="" S MDFLG=1 Q
I +MDLOC>0 S MDVSTD="A;"_MDVSTD_";"_MDLOC
E D NOW^%DTC S MDVSTD=%
S MDOBC=MDOBC+1
Q
NEW ; New Order Segment
S MDIFN=+$P(MDX,"|",3) I 'MDIFN S MDFLG=1 Q
S MDPROV=+$P(MDX,"|",11) I 'MDPROV S MDFLG=1 Q
S MDQTIM=$P(MDX,"|",8),MDQTIM=$P(MDQTIM,"^",6)
S MDREQ=$P(MDX,"|",16) S MDREQ=$$FMDTE(MDREQ) I 'MDREQ S MDFLG=1 Q
S MDREQ=$S(MDQTIM="Z24":$$FMADD^XLFDT(MDREQ,0,24),MDQTIM="Z48":$$FMADD^XLFDT(MDREQ,0,48),MDQTIM="Z72":$$FMADD^XLFDT(MDREQ,0,72),MDQTIM="ZW":$$FMADD^XLFDT(MDREQ,7),MDQTIM="ZM":$$FMADD^XLFDT(MDREQ,30),1:MDREQ)
; Retrieve Consult Number
N MDFDA
S MDCON=$$PKGID^ORX8(MDIFN) I 'MDCON S MDFLG=1 Q
Q
OBR ; Check OBR
S MDPROC=$P(MDX,"|",5)
I $E($P(MDPROC,"^",6),3,5)'["PRC" S MDFLG=1 Q
S MDCPROC=$P(MDPROC,"^",4) I 'MDCPROC S MDFLG=1 Q
; Get Procedure for CP IEN
S MDPROC=$$CPROC^GMRCCP(MDCPROC) I 'MDPROC S MDFLG=1 Q
S MDSINP=$$HIGHV(MDPROC) I +MDSINP'>0 S MDFLG=1 Q
S (MDINST,MDINT)=0 F MDIN=0:0 S MDIN=$O(^MDS(702.01,MDPROC,.1,MDIN)) Q:MDIN<1!(+MDINST) S MDINT=+$G(^(MDIN,0)) D
.I +$$GET1^DIQ(702.09,+MDINT,".13","I") S MDINST=MDINT Q
I +$P(MDSINP,"^",2)=2 D Q
.I +MDINP S MDVSTD="",MDOBC=MDOBC+1 Q
.S MDVSTD=MDREQ,MDOBC=MDOBC+1 Q
I +$P(MDSINP,"^",2)=3 D Q
.I +MDINP S MDVSTD="",MDOBC=MDOBC+1 Q
I +$P(MDSINP,"^",2)=1 D Q
.I '+MDINP S MDVSTD="" Q
.S MDVSTD=MDREQ,MDOBC=MDOBC+1 Q
;I +MDINP&('$P(^MDS(702.01,MDPROC,0),"^",5)) S MDFLG=1 Q
I +MDINP S MDVSTD=MDREQ,MDOBC=MDOBC+1 Q
S MDVSTD=MDREQ,MDOBC=MDOBC+1 Q
Q
CANCEL ; Cancel/Discontinue
K MDR S MDIFN=+$P(MDX,"|",3),MDCON=+$P(MDX,"|",4),MDCANC=1
I 'MDIFN S MDFLG=1 Q
I 'MDCON S MDFLG=1 Q
S MDPROV=+$P(MDX,"|",13) I 'MDPROV S MDFLG=1 Q
S MDREQ=$P(MDX,"|",16) I 'MDREQ S MDFLG=1 Q
;
;MDINST is set to 0 initially, but setting again in case it was reset
;previously
;
S MDINST=0
F S MDINST=$O(^MDD(702,"ACON",MDCON,MDINST)) Q:'MDINST D
. Q:$G(^MDD(702,+MDINST,0))=""
. I "5"[$P(^MDD(702,+MDINST,0),U,9) S MDCANR=$$CANCEL^MDHL7B(+MDINST)
. N MDFDA S MDFDA(702,MDINST_",",.09)=6
. D FILE^DIE("K","MDFDA") K MDFDA
. N MDHEMO S MDHEMO=+$$GET1^DIQ(702,+MDINST,".04:.06","I")
. Q:MDHEMO<2
. Q:$G(^MDK(704.202,+MDINST,0))=""
. S MDFDA(704.202,+MDINST_",",.09)=0
. D FILE^DIE("","MDFDA")
. K ^MDK(704.202,"AS",1,+MDINST)
. S ^MDK(704.202,"AS",0,+MDINST)=""
Q
CHKIN(MDFN,MDREQ,MDPROV,MDATA,MDVSTD) ; [Procedure] Check In Study
N MDCART,MDREZ,MDX1,MDFDA,MDIEN,MDIENS,MDERR,MDHL7,MDHOLD,MDSCHD,MDMAXD,MDXY,MDNOW S MDCART=0
F MDX1=2:1:5 D
.I $P(MDATA,U,MDX1)]"" S MDFDA(702,$P(MDATA,U,1),$P("^.04^.05^.11^.07",U,MDX1))=$P(MDATA,U,MDX1)
; Remove code after instrument testing available
; End of code removal after instrument available for testin
S MDSCHD=$S($L(MDVSTD,";")=1:MDVSTD,1:$P(MDVSTD,";",2)),MDMAXD=DT+.24
S MDFDA(702,$P(MDATA,U,1),.09)=$S(MDSCHD="":0,MDSCHD>MDMAXD:0,1:5) ; Status = Checked-In
I +$P(MDATA,U,4),+$G(^MDS(702.09,+$P(MDATA,U,4),"CS")) S MDCART=1
I $P(MDATA,U,1)="+1," D
.S MDFDA(702,"+1,",.01)=MDFN
.S MDFDA(702,"+1,",.02)=$$NOW^XLFDT()
.S MDFDA(702,"+1,",.03)=MDPROV
.S:+MDSCHD MDFDA(702,"+1,",.14)=MDSCHD
.D UPDATE^DIE("","MDFDA","MDIEN","MDERR") Q:$D(MDERR)
.Q:MDSCHD>MDMAXD!(MDSCHD="")
.S MDIENS=MDIEN(1)_",",MDXY=+$P(MDATA,U,2),MDHOLD="" I +MDXY D
..Q:$P(^MDS(702.01,MDXY,0),U,6)'=2
..S MDHOLD=$P($G(^MDD(702,MDIEN(1),0)),"^",7),MDNOW=$$NOW^XLFDT()
..S $P(^MDD(702,MDIEN(1),0),"^",7)=MDSCHD
.S MDHL7=$$SUB^MDHL7B(MDIEN(1))
.I +MDHL7=-1 S MDFDA(702,MDIENS,.09)=2,MDFDA(702,MDIENS,.08)=$P(MDHL7,U,2)
.I +MDHL7=1 S MDFDA(702,MDIENS,.09)=5,MDFDA(702,MDIENS,.08)=""
.D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR")
I +MDCART>0 D
.S MDREZ=$$NEWTIUN^MDRPCOT(+MDIEN(1))
.I +MDREZ<0 D FILEMSG^MDRPCOT(+MDIEN(1),"TIU",2,MDREZ)
.S MDREZ=$$SUBMIT^MDRPCOT1(MDIEN(1))
.D FILEMSG^MDRPCOT(+MDIEN(1),"IMAGING",$S(+MDREZ>0:+MDREZ,1:2),MDREZ)
Q:MDSCHD>MDMAXD!(MDSCHD="")
D:+$G(MDIENS)
.S MDXY=+$P(MDATA,U,2) Q:'MDXY
.I $P(^MDS(702.01,MDXY,0),U,6)=2 D Q ; Renal Check-In
..D CP^MDKUTL(+MDIENS)
..S:$G(MDHOLD)'="" MDFDA(702,+MDIENS_",",.07)=MDHOLD
..S MDFDA(702,+MDIENS_",",.09)=5
..D FILE^DIE("","MDFDA","MDERR")
Q
FMDTE(DATE) ; Convert HL-7 formatted date to a Fileman formatted date
N X
S X="" I DATE D
.S X=$$HL7TFM^XLFDT(DATE,"L")
Q X
HIGHV(MDHV) ; Return flag indicator whether procedure is use for auto check-in
N MDANS,MDK,MDKY,MDLST S MDANS=0
D GETLST^XPAR(.MDLST,"SYS","MD CHECK-IN PROCEDURE LIST")
F MDK=0:0 S MDK=$O(MDLST(MDK)) Q:MDK<1 S MDKY=$G(MDLST(MDK)) D
.I MDHV=+$P(MDKY,"^") S MDANS=MDKY
Q MDANS
GETAPPT(MDDPAT,MDDA) ; Get appointment
N DFN,MDALP,MDARES,MDCKDT K ^UTILITY("VASD",$J) S DFN=MDDPAT
S X1=DT,X2=365 D C^%DTC S VASD("T")=X+.24,VASD("F")=DT,VASD("W")="129",VASD("C",+MDDA)=+MDDA D SDA^VADPT
S MDARES=0 F MDALP=0:0 S MDALP=$O(^UTILITY("VASD",$J,MDALP)) Q:MDALP<1 D
. S MDCKDT=$G(^(MDALP,"I")) ;this naked reference refers to the full reference to ^UTILITY("VASD" above
. S MDARES=MDCKDT
K ^UTILITY("VASD",$J),VASD,X1,X2,X
Q MDARES
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDWOR 7955 printed Apr 09, 2024@20:47:54 Page 2
MDWOR ; HOIFO/NCA - Main Routine to Decode HL7 ; 1/29/19 4:55pm
+1 ;;1.0;CLINICAL PROCEDURES;**14,11,21,20,37,42,54,69**;Apr 01,2004;Build 2
+2 ; Reference IA# 2263 [Supported] XPAR calls
+3 ; 3468 [Subscription] Call GMRCCP.
+4 ; 3071 [Subscription] Call $$PKGID^ORX8.
+5 ; 10035 [Supported] Access DPT("B"
+6 ; 10040 [Supported] Access SC(
+7 ; 10061 [Supported] VADPT call
+8 ; 10103 [Supported] XLFDT calls
+9 ; 03/18/2014 KAM MD*1*37 Rem Ticket 451758 Auto Check-in issue
EN(MDMSG) ; Entry Point for CPRS and pass MSG in MDMSG
+1 NEW DFN,MDCON,MDCPROC,MDCANC,MDCANR,MDFN,MDIFN,MDINST,MDFLG,MDINT,MDL,MDIN,MDINP,MDINST,MDLOC,MDNAM,MDOBC,MDOBX,MDOPRO,MDPROC,MDPAT
+2 NEW MDLL,MDK1,MDPROV,MDREQ,MDQTIM,MDROOT,MDRR,MDSINP,MDVSTD,MDX
SET MDVSTD=""
+3 SET (MDFLG,MDINP,MDINST,MDCANC,MDOBC)=0
FOR MDL=0:0
SET MDL=$ORDER(MDMSG(MDL))
if MDL<1!(+MDFLG>0)
QUIT
SET MDX=$GET(MDMSG(MDL))
Begin DoDot:1
+4 IF $EXTRACT(MDX,1,3)="MSH"
DO MSH
QUIT
+5 IF $EXTRACT(MDX,1,3)="PID"
DO PID
QUIT
+6 IF $EXTRACT(MDX,1,3)="PV1"
DO PV1
QUIT
+7 IF $EXTRACT(MDX,1,3)="ORC"
DO ORC
QUIT
+8 IF $EXTRACT(MDX,1,3)="OBR"
DO OBR
QUIT
+9 IF $EXTRACT(MDX,1,3)="OBX"
if MDOBC<1
DO OBX
QUIT
+10 QUIT
End DoDot:1
+11 DO GETLST^XPAR(.MDLL,"SYS","MD CLINIC ASSOCIATION")
+12 IF +MDFLG<1&(+MDCANC<1)&(MDVSTD="")
FOR MDK1=0:0
SET MDK1=$ORDER(MDLL(MDK1))
if MDK1<1
QUIT
SET MDROOT=$GET(MDLL(MDK1))
IF +$PIECE(MDROOT,";",2)=MDPROC
Begin DoDot:1
+13 SET MDRR=0
SET MDIFN=MDFN
SET MDRR=$$GETAPPT(MDIFN,+$PIECE(MDROOT,"^",2))
+14 if +MDRR
SET MDVSTD="A"_";"_$PIECE(MDRR,"^",1)_";"_+$PIECE(MDROOT,"^",2)
End DoDot:1
if +MDRR
QUIT
+15 IF +MDFLG<1&(MDVSTD'="")
FOR MDK1=0:0
SET MDK1=$ORDER(MDLL(MDK1))
if MDK1<1
QUIT
SET MDROOT=$PIECE($GET(MDLL(MDK1)),"^",2)
IF +$PIECE(MDROOT,";",2)=MDPROC
Begin DoDot:1
+16 IF +$PIECE(MDVSTD,";",3)>0&(+MDROOT=$PIECE(MDVSTD,";",3))
SET MDFLG=0
QUIT
End DoDot:1
+17 ;
+18 ; 03/18/2014 KAM MD*1*37 Rem Ticket 451758
+19 ; Commented out the next line - setting the MDFLG to 1 on a clinic
+20 ; change is not needed
+21 ;.I +$P(MDVSTD,";",3)>0&(+MDROOT'=$P(MDVSTD,";",3)) S MDFLG=1 Q
+22 ;
+23 IF +MDFLG<1&(+MDCANC<1)
SET MDATA="+1,^"_MDPROC_"^"_+MDCON_"^"_MDINST_"^"_MDVSTD
DO CHKIN(MDFN,MDREQ,MDPROV,MDATA,MDVSTD)
+24 QUIT
MSH ; Decode MSH
+1 IF $PIECE(MDX,"|",2)'="^~\&"
SET MDFLG=1
QUIT
+2 IF $PIECE(MDX,"|",3)'="ORDER ENTRY"
SET MDFLG=1
QUIT
+3 IF $PIECE(MDX,"|",9)'="ORM"
SET MDFLG=1
QUIT
+4 QUIT
PID ; Check PID
+1 SET MDNAM=$PIECE(MDX,"|",6)
SET DFN=$PIECE(MDX,"|",4)
+2 IF '$DATA(^DPT("B",$EXTRACT(MDNAM,1,30),DFN))
SET MDFLG=1
+3 SET MDFN=DFN
+4 QUIT
PV1 ; Check PV1
+1 SET MDPAT=$PIECE(MDX,"|",3)
IF MDPAT'?1U!("IO"'[MDPAT)
SET MDFLG=1
QUIT
+2 IF MDPAT="I"
SET MDINP=1
+3 SET MDLOC=+$PIECE(MDX,"|",4)
IF $GET(^SC(MDLOC,0))=""
SET MDFLG=1
QUIT
+4 if MDINP>0
SET MDLOC=""
+5 QUIT
ORC ; Check ORC
+1 IF $PIECE(MDX,"|",2)="NW"
DO NEW
QUIT
+2 IF $PIECE(MDX,"|",2)="DC"
DO CANCEL
QUIT
+3 SET MDFLG=1
+4 QUIT
OBX ; Check OBX
+1 NEW %,ANSWER,MDCV,MDOBX
+2 SET MDOBX=$PIECE(MDX,"|",6)
+3 IF '+$$GET^XPAR("SYS","MD USE APPT WITH PROCEDURE",1)
SET MDOBC=MDOBC+1
QUIT
+4 SET MDVSTD=$PIECE(MDOBX,"Visit Date: ",2)
+5 SET MDCV=$PIECE(MDVSTD," ",1,2)
+6 IF MDCV=""!(MDCV["UNKNOWN")
SET MDFLG=1
QUIT
+7 SET MDVSTD=$PIECE(MDCV," ")_"@"_$PIECE(MDCV," ",2)
+8 DO DT^DILF("T",MDVSTD,.ANSWER)
+9 if ANSWER<0
SET ANSWER=""
+10 SET MDVSTD=ANSWER
IF MDVSTD=""
SET MDFLG=1
QUIT
+11 IF +MDLOC>0
SET MDVSTD="A;"_MDVSTD_";"_MDLOC
+12 IF '$TEST
DO NOW^%DTC
SET MDVSTD=%
+13 SET MDOBC=MDOBC+1
+14 QUIT
NEW ; New Order Segment
+1 SET MDIFN=+$PIECE(MDX,"|",3)
IF 'MDIFN
SET MDFLG=1
QUIT
+2 SET MDPROV=+$PIECE(MDX,"|",11)
IF 'MDPROV
SET MDFLG=1
QUIT
+3 SET MDQTIM=$PIECE(MDX,"|",8)
SET MDQTIM=$PIECE(MDQTIM,"^",6)
+4 SET MDREQ=$PIECE(MDX,"|",16)
SET MDREQ=$$FMDTE(MDREQ)
IF 'MDREQ
SET MDFLG=1
QUIT
+5 SET MDREQ=$SELECT(MDQTIM="Z24":$$FMADD^XLFDT(MDREQ,0,24),MDQTIM="Z48":$$FMADD^XLFDT(MDREQ,0,48),MDQTIM="Z72":$$FMADD^XLFDT(MDREQ,0,72),MDQTIM="ZW":$$FMADD^XLFDT(MDREQ,7),MDQTIM="ZM":$$FMADD^XLFDT(MDREQ,30),1:MDREQ)
+6 ; Retrieve Consult Number
+7 NEW MDFDA
+8 SET MDCON=$$PKGID^ORX8(MDIFN)
IF 'MDCON
SET MDFLG=1
QUIT
+9 QUIT
OBR ; Check OBR
+1 SET MDPROC=$PIECE(MDX,"|",5)
+2 IF $EXTRACT($PIECE(MDPROC,"^",6),3,5)'["PRC"
SET MDFLG=1
QUIT
+3 SET MDCPROC=$PIECE(MDPROC,"^",4)
IF 'MDCPROC
SET MDFLG=1
QUIT
+4 ; Get Procedure for CP IEN
+5 SET MDPROC=$$CPROC^GMRCCP(MDCPROC)
IF 'MDPROC
SET MDFLG=1
QUIT
+6 SET MDSINP=$$HIGHV(MDPROC)
IF +MDSINP'>0
SET MDFLG=1
QUIT
+7 SET (MDINST,MDINT)=0
FOR MDIN=0:0
SET MDIN=$ORDER(^MDS(702.01,MDPROC,.1,MDIN))
if MDIN<1!(+MDINST)
QUIT
SET MDINT=+$GET(^(MDIN,0))
Begin DoDot:1
+8 IF +$$GET1^DIQ(702.09,+MDINT,".13","I")
SET MDINST=MDINT
QUIT
End DoDot:1
+9 IF +$PIECE(MDSINP,"^",2)=2
Begin DoDot:1
+10 IF +MDINP
SET MDVSTD=""
SET MDOBC=MDOBC+1
QUIT
+11 SET MDVSTD=MDREQ
SET MDOBC=MDOBC+1
QUIT
End DoDot:1
QUIT
+12 IF +$PIECE(MDSINP,"^",2)=3
Begin DoDot:1
+13 IF +MDINP
SET MDVSTD=""
SET MDOBC=MDOBC+1
QUIT
End DoDot:1
QUIT
+14 IF +$PIECE(MDSINP,"^",2)=1
Begin DoDot:1
+15 IF '+MDINP
SET MDVSTD=""
QUIT
+16 SET MDVSTD=MDREQ
SET MDOBC=MDOBC+1
QUIT
End DoDot:1
QUIT
+17 ;I +MDINP&('$P(^MDS(702.01,MDPROC,0),"^",5)) S MDFLG=1 Q
+18 IF +MDINP
SET MDVSTD=MDREQ
SET MDOBC=MDOBC+1
QUIT
+19 SET MDVSTD=MDREQ
SET MDOBC=MDOBC+1
QUIT
+20 QUIT
CANCEL ; Cancel/Discontinue
+1 KILL MDR
SET MDIFN=+$PIECE(MDX,"|",3)
SET MDCON=+$PIECE(MDX,"|",4)
SET MDCANC=1
+2 IF 'MDIFN
SET MDFLG=1
QUIT
+3 IF 'MDCON
SET MDFLG=1
QUIT
+4 SET MDPROV=+$PIECE(MDX,"|",13)
IF 'MDPROV
SET MDFLG=1
QUIT
+5 SET MDREQ=$PIECE(MDX,"|",16)
IF 'MDREQ
SET MDFLG=1
QUIT
+6 ;
+7 ;MDINST is set to 0 initially, but setting again in case it was reset
+8 ;previously
+9 ;
+10 SET MDINST=0
+11 FOR
SET MDINST=$ORDER(^MDD(702,"ACON",MDCON,MDINST))
if 'MDINST
QUIT
Begin DoDot:1
+12 if $GET(^MDD(702,+MDINST,0))=""
QUIT
+13 IF "5"[$PIECE(^MDD(702,+MDINST,0),U,9)
SET MDCANR=$$CANCEL^MDHL7B(+MDINST)
+14 NEW MDFDA
SET MDFDA(702,MDINST_",",.09)=6
+15 DO FILE^DIE("K","MDFDA")
KILL MDFDA
+16 NEW MDHEMO
SET MDHEMO=+$$GET1^DIQ(702,+MDINST,".04:.06","I")
+17 if MDHEMO<2
QUIT
+18 if $GET(^MDK(704.202,+MDINST,0))=""
QUIT
+19 SET MDFDA(704.202,+MDINST_",",.09)=0
+20 DO FILE^DIE("","MDFDA")
+21 KILL ^MDK(704.202,"AS",1,+MDINST)
+22 SET ^MDK(704.202,"AS",0,+MDINST)=""
End DoDot:1
+23 QUIT
CHKIN(MDFN,MDREQ,MDPROV,MDATA,MDVSTD) ; [Procedure] Check In Study
+1 NEW MDCART,MDREZ,MDX1,MDFDA,MDIEN,MDIENS,MDERR,MDHL7,MDHOLD,MDSCHD,MDMAXD,MDXY,MDNOW
SET MDCART=0
+2 FOR MDX1=2:1:5
Begin DoDot:1
+3 IF $PIECE(MDATA,U,MDX1)]""
SET MDFDA(702,$PIECE(MDATA,U,1),$PIECE("^.04^.05^.11^.07",U,MDX1))=$PIECE(MDATA,U,MDX1)
End DoDot:1
+4 ; Remove code after instrument testing available
+5 ; End of code removal after instrument available for testin
+6 SET MDSCHD=$SELECT($LENGTH(MDVSTD,";")=1:MDVSTD,1:$PIECE(MDVSTD,";",2))
SET MDMAXD=DT+.24
+7 ; Status = Checked-In
SET MDFDA(702,$PIECE(MDATA,U,1),.09)=$SELECT(MDSCHD="":0,MDSCHD>MDMAXD:0,1:5)
+8 IF +$PIECE(MDATA,U,4)
IF +$GET(^MDS(702.09,+$PIECE(MDATA,U,4),"CS"))
SET MDCART=1
+9 IF $PIECE(MDATA,U,1)="+1,"
Begin DoDot:1
+10 SET MDFDA(702,"+1,",.01)=MDFN
+11 SET MDFDA(702,"+1,",.02)=$$NOW^XLFDT()
+12 SET MDFDA(702,"+1,",.03)=MDPROV
+13 if +MDSCHD
SET MDFDA(702,"+1,",.14)=MDSCHD
+14 DO UPDATE^DIE("","MDFDA","MDIEN","MDERR")
if $DATA(MDERR)
QUIT
+15 if MDSCHD>MDMAXD!(MDSCHD="")
QUIT
+16 SET MDIENS=MDIEN(1)_","
SET MDXY=+$PIECE(MDATA,U,2)
SET MDHOLD=""
IF +MDXY
Begin DoDot:2
+17 if $PIECE(^MDS(702.01,MDXY,0),U,6)'=2
QUIT
+18 SET MDHOLD=$PIECE($GET(^MDD(702,MDIEN(1),0)),"^",7)
SET MDNOW=$$NOW^XLFDT()
+19 SET $PIECE(^MDD(702,MDIEN(1),0),"^",7)=MDSCHD
End DoDot:2
+20 SET MDHL7=$$SUB^MDHL7B(MDIEN(1))
+21 IF +MDHL7=-1
SET MDFDA(702,MDIENS,.09)=2
SET MDFDA(702,MDIENS,.08)=$PIECE(MDHL7,U,2)
+22 IF +MDHL7=1
SET MDFDA(702,MDIENS,.09)=5
SET MDFDA(702,MDIENS,.08)=""
+23 if $DATA(MDFDA)
DO FILE^DIE("","MDFDA","MDERR")
End DoDot:1
+24 IF +MDCART>0
Begin DoDot:1
+25 SET MDREZ=$$NEWTIUN^MDRPCOT(+MDIEN(1))
+26 IF +MDREZ<0
DO FILEMSG^MDRPCOT(+MDIEN(1),"TIU",2,MDREZ)
+27 SET MDREZ=$$SUBMIT^MDRPCOT1(MDIEN(1))
+28 DO FILEMSG^MDRPCOT(+MDIEN(1),"IMAGING",$SELECT(+MDREZ>0:+MDREZ,1:2),MDREZ)
End DoDot:1
+29 if MDSCHD>MDMAXD!(MDSCHD="")
QUIT
+30 if +$GET(MDIENS)
Begin DoDot:1
+31 SET MDXY=+$PIECE(MDATA,U,2)
if 'MDXY
QUIT
+32 ; Renal Check-In
IF $PIECE(^MDS(702.01,MDXY,0),U,6)=2
Begin DoDot:2
+33 DO CP^MDKUTL(+MDIENS)
+34 if $GET(MDHOLD)'=""
SET MDFDA(702,+MDIENS_",",.07)=MDHOLD
+35 SET MDFDA(702,+MDIENS_",",.09)=5
+36 DO FILE^DIE("","MDFDA","MDERR")
End DoDot:2
QUIT
End DoDot:1
+37 QUIT
FMDTE(DATE) ; Convert HL-7 formatted date to a Fileman formatted date
+1 NEW X
+2 SET X=""
IF DATE
Begin DoDot:1
+3 SET X=$$HL7TFM^XLFDT(DATE,"L")
End DoDot:1
+4 QUIT X
HIGHV(MDHV) ; Return flag indicator whether procedure is use for auto check-in
+1 NEW MDANS,MDK,MDKY,MDLST
SET MDANS=0
+2 DO GETLST^XPAR(.MDLST,"SYS","MD CHECK-IN PROCEDURE LIST")
+3 FOR MDK=0:0
SET MDK=$ORDER(MDLST(MDK))
if MDK<1
QUIT
SET MDKY=$GET(MDLST(MDK))
Begin DoDot:1
+4 IF MDHV=+$PIECE(MDKY,"^")
SET MDANS=MDKY
End DoDot:1
+5 QUIT MDANS
GETAPPT(MDDPAT,MDDA) ; Get appointment
+1 NEW DFN,MDALP,MDARES,MDCKDT
KILL ^UTILITY("VASD",$JOB)
SET DFN=MDDPAT
+2 SET X1=DT
SET X2=365
DO C^%DTC
SET VASD("T")=X+.24
SET VASD("F")=DT
SET VASD("W")="129"
SET VASD("C",+MDDA)=+MDDA
DO SDA^VADPT
+3 SET MDARES=0
FOR MDALP=0:0
SET MDALP=$ORDER(^UTILITY("VASD",$JOB,MDALP))
if MDALP<1
QUIT
Begin DoDot:1
+4 ;this naked reference refers to the full reference to ^UTILITY("VASD" above
SET MDCKDT=$GET(^(MDALP,"I"))
+5 SET MDARES=MDCKDT
End DoDot:1
+6 KILL ^UTILITY("VASD",$JOB),VASD,X1,X2,X
+7 QUIT MDARES
