MDWORC ; HOIFO/NCA - Main Routine to Decode HL7 from Consult ;Jun 19, 2018@17:15
;;1.0;CLINICAL PROCEDURES;**14,54**;Apr 01,2004;Build 14
; Reference IA #10035 [Supported] Access Patient file DPT
; 10040 [Supported] Hospital Location File SC
; 10103 [Supported] XLFDT calls
EN(MDMSG) ; Entry Point for Consult and pass MSG in MDMSG
N DFN,MDCON,MDCPROC,MDCANC,MDCANR,MDFN,MDIFN,MDINST,MDFLG,MDL,MDLOC,MDNAM,MDPROC,MDPAT,MDPROV,MDREQ,MDX
S (MDFLG,MDCANC)=0 F MDL=0:0 S MDL=$O(MDMSG(MDL)) Q:MDL<1!(MDFLG) 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)="NTE" Q
.Q
Q
MSH ; Decode MSH
I $P(MDX,"|",2)'="^~\&" S MDFLG=1 Q
I $P(MDX,"|",3)'="CONSULTS" 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
S MDLOC=+$P(MDX,"|",4) I $G(^SC(MDLOC,0))="" S MDFLG=1 Q
Q
ORC ; Check ORC
I $P(MDX,"|",2)'="OD",($P(MDX,"|",2)'="OC"),($P(MDX,"|",2)'="XX") Q
I $P(MDX,"|",2)="XX" D RESUBM
D CANCEL
Q
CANCEL ; Cancel/Discontinue
K MDR S MDIFN=+$P(MDX,"|",3),MDCON=+$P(MDX,"|",4)
I 'MDIFN S MDFLG=1 Q
I 'MDCON S MDFLG=1 Q
I $P(MDX,"|",6)'="CA",($P(MDX,"|",6)'="DC") Q
S MDPROV=+$P(MDX,"|",13) I 'MDPROV S MDFLG=1 Q
S MDREQ=$P(MDX,"|",16) I 'MDREQ S MDFLG=1 Q
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,MDCANC=1
. 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
RESUBM ; Resubmit a cancelled order
N MDERR,MDHL7,MDHOLD,MDMAXD,MDNOW,MDSCHD,MDVSTD,MDXY
Q:$P(MDX,"|",2)'="XX"
K MDR S MDIFN=+$P(MDX,"|",3),MDCON=+$P(MDX,"|",4)
I 'MDIFN S MDFLG=1 Q
I 'MDCON S MDFLG=1 Q
S MDPROV=+$P(MDX,"|",11) I 'MDPROV S MDFLG=1 Q
S MDREQ=$P(MDX,"|",16) S:MDREQ MDREQ=$$FMDTE^MDWOR(MDREQ) I 'MDREQ S MDFLG=1 Q
S MDINST=$O(^MDD(702,"ACON",MDCON,0)) Q:'MDINST
S MDVSTD=$P($G(^MDD(702,MDINST,0)),"^",7)
S MDSCHD=$S($L(MDVSTD,";")=1:MDVSTD,1:$P(MDVSTD,";",2)),MDMAXD=DT+.24
Q:$$GET1^DIQ(702,MDINST_",",.09,"I")'=6
N MDFDA,MDIENS,MDERR
S MDFDA(702,MDINST_",",.07)=MDVSTD
S MDFDA(702,MDINST_",",.09)=$S(MDSCHD>MDMAXD:0,1:5)
D FILE^DIE("K","MDFDA") S MDHOLD="" K MDFDA
Q:MDSCHD>MDMAXD
S MDXY=$P(^MDD(702,MDINST,0),"^",4)
I $P($G(^MDS(702.01,+MDXY,0)),"^",6)=2 S MDHOLD=$P(^MDD(702,MDINST,0),"^",7),MDNOW=$$NOW^XLFDT(),$P(^MDD(702,MDINST,0),"^",7)=$S(MDNOW>MDSCHD:MDSCHD,1:MDNOW)
S MDIENS=MDINST_",",MDHL7=$$SUB^MDHL7B(+MDIENS)
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") K MDFDA,MDERR
N MDHEMO S MDHEMO=+$$GET1^DIQ(702,+MDIENS,".04:.06","I")
Q:MDHEMO<2
S:$G(MDHOLD)'="" $P(^MDD(702,MDINST,0),"^",7)=MDHOLD
Q:$G(^MDK(704.202,+MDINST,0))=""
S MDFDA(704.202,+MDINST_",",.09)=1
D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR") K MDFDA,MDERR
K ^MDK(704.202,"AS",0,+MDINST)
S ^MDK(704.202,"AS",1,+MDINST)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDWORC 3562 printed Apr 09, 2024@20:48:11 Page 2
MDWORC ; HOIFO/NCA - Main Routine to Decode HL7 from Consult ;Jun 19, 2018@17:15
+1 ;;1.0;CLINICAL PROCEDURES;**14,54**;Apr 01,2004;Build 14
+2 ; Reference IA #10035 [Supported] Access Patient file DPT
+3 ; 10040 [Supported] Hospital Location File SC
+4 ; 10103 [Supported] XLFDT calls
EN(MDMSG) ; Entry Point for Consult and pass MSG in MDMSG
+1 NEW DFN,MDCON,MDCPROC,MDCANC,MDCANR,MDFN,MDIFN,MDINST,MDFLG,MDL,MDLOC,MDNAM,MDPROC,MDPAT,MDPROV,MDREQ,MDX
+2 SET (MDFLG,MDCANC)=0
FOR MDL=0:0
SET MDL=$ORDER(MDMSG(MDL))
if MDL<1!(MDFLG)
QUIT
SET MDX=$GET(MDMSG(MDL))
Begin DoDot:1
+3 IF $EXTRACT(MDX,1,3)="MSH"
DO MSH
QUIT
+4 IF $EXTRACT(MDX,1,3)="PID"
DO PID
QUIT
+5 IF $EXTRACT(MDX,1,3)="PV1"
DO PV1
QUIT
+6 IF $EXTRACT(MDX,1,3)="ORC"
DO ORC
QUIT
+7 IF $EXTRACT(MDX,1,3)="NTE"
QUIT
+8 QUIT
End DoDot:1
+9 QUIT
MSH ; Decode MSH
+1 IF $PIECE(MDX,"|",2)'="^~\&"
SET MDFLG=1
QUIT
+2 IF $PIECE(MDX,"|",3)'="CONSULTS"
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 SET MDLOC=+$PIECE(MDX,"|",4)
IF $GET(^SC(MDLOC,0))=""
SET MDFLG=1
QUIT
+3 QUIT
ORC ; Check ORC
+1 IF $PIECE(MDX,"|",2)'="OD"
IF ($PIECE(MDX,"|",2)'="OC")
IF ($PIECE(MDX,"|",2)'="XX")
QUIT
+2 IF $PIECE(MDX,"|",2)="XX"
DO RESUBM
+3 DO CANCEL
+4 QUIT
CANCEL ; Cancel/Discontinue
+1 KILL MDR
SET MDIFN=+$PIECE(MDX,"|",3)
SET MDCON=+$PIECE(MDX,"|",4)
+2 IF 'MDIFN
SET MDFLG=1
QUIT
+3 IF 'MDCON
SET MDFLG=1
QUIT
+4 IF $PIECE(MDX,"|",6)'="CA"
IF ($PIECE(MDX,"|",6)'="DC")
QUIT
+5 SET MDPROV=+$PIECE(MDX,"|",13)
IF 'MDPROV
SET MDFLG=1
QUIT
+6 SET MDREQ=$PIECE(MDX,"|",16)
IF 'MDREQ
SET MDFLG=1
QUIT
+7 SET MDINST=0
+8 FOR
SET MDINST=$ORDER(^MDD(702,"ACON",MDCON,MDINST))
if 'MDINST
QUIT
Begin DoDot:1
+9 if $GET(^MDD(702,+MDINST,0))=""
QUIT
+10 IF "5"[$PIECE(^MDD(702,+MDINST,0),U,9)
SET MDCANR=$$CANCEL^MDHL7B(+MDINST)
+11 NEW MDFDA
SET MDFDA(702,+MDINST_",",.09)=6
SET MDCANC=1
+12 DO FILE^DIE("K","MDFDA")
KILL MDFDA
+13 NEW MDHEMO
SET MDHEMO=+$$GET1^DIQ(702,+MDINST,".04:.06","I")
+14 if MDHEMO<2
QUIT
+15 if $GET(^MDK(704.202,+MDINST,0))=""
QUIT
+16 SET MDFDA(704.202,+MDINST_",",.09)=0
+17 DO FILE^DIE("","MDFDA")
+18 KILL ^MDK(704.202,"AS",1,+MDINST)
+19 SET ^MDK(704.202,"AS",0,+MDINST)=""
End DoDot:1
+20 QUIT
RESUBM ; Resubmit a cancelled order
+1 NEW MDERR,MDHL7,MDHOLD,MDMAXD,MDNOW,MDSCHD,MDVSTD,MDXY
+2 if $PIECE(MDX,"|",2)'="XX"
QUIT
+3 KILL MDR
SET MDIFN=+$PIECE(MDX,"|",3)
SET MDCON=+$PIECE(MDX,"|",4)
+4 IF 'MDIFN
SET MDFLG=1
QUIT
+5 IF 'MDCON
SET MDFLG=1
QUIT
+6 SET MDPROV=+$PIECE(MDX,"|",11)
IF 'MDPROV
SET MDFLG=1
QUIT
+7 SET MDREQ=$PIECE(MDX,"|",16)
if MDREQ
SET MDREQ=$$FMDTE^MDWOR(MDREQ)
IF 'MDREQ
SET MDFLG=1
QUIT
+8 SET MDINST=$ORDER(^MDD(702,"ACON",MDCON,0))
if 'MDINST
QUIT
+9 SET MDVSTD=$PIECE($GET(^MDD(702,MDINST,0)),"^",7)
+10 SET MDSCHD=$SELECT($LENGTH(MDVSTD,";")=1:MDVSTD,1:$PIECE(MDVSTD,";",2))
SET MDMAXD=DT+.24
+11 if $$GET1^DIQ(702,MDINST_",",.09,"I")'=6
QUIT
+12 NEW MDFDA,MDIENS,MDERR
+13 SET MDFDA(702,MDINST_",",.07)=MDVSTD
+14 SET MDFDA(702,MDINST_",",.09)=$SELECT(MDSCHD>MDMAXD:0,1:5)
+15 DO FILE^DIE("K","MDFDA")
SET MDHOLD=""
KILL MDFDA
+16 if MDSCHD>MDMAXD
QUIT
+17 SET MDXY=$PIECE(^MDD(702,MDINST,0),"^",4)
+18 IF $PIECE($GET(^MDS(702.01,+MDXY,0)),"^",6)=2
SET MDHOLD=$PIECE(^MDD(702,MDINST,0),"^",7)
SET MDNOW=$$NOW^XLFDT()
SET $PIECE(^MDD(702,MDINST,0),"^",7)=$SELECT(MDNOW>MDSCHD:MDSCHD,1:MDNOW)
+19 SET MDIENS=MDINST_","
SET MDHL7=$$SUB^MDHL7B(+MDIENS)
+20 IF +MDHL7=-1
SET MDFDA(702,MDIENS,.09)=2
SET MDFDA(702,MDIENS,.08)=$PIECE(MDHL7,U,2)
+21 IF +MDHL7=1
SET MDFDA(702,MDIENS,.09)=5
SET MDFDA(702,MDIENS,.08)=""
+22 if $DATA(MDFDA)
DO FILE^DIE("","MDFDA","MDERR")
KILL MDFDA,MDERR
+23 NEW MDHEMO
SET MDHEMO=+$$GET1^DIQ(702,+MDIENS,".04:.06","I")
+24 if MDHEMO<2
QUIT
+25 if $GET(MDHOLD)'=""
SET $PIECE(^MDD(702,MDINST,0),"^",7)=MDHOLD
+26 if $GET(^MDK(704.202,+MDINST,0))=""
QUIT
+27 SET MDFDA(704.202,+MDINST_",",.09)=1
+28 if $DATA(MDFDA)
DO FILE^DIE("","MDFDA","MDERR")
KILL MDFDA,MDERR
+29 KILL ^MDK(704.202,"AS",0,+MDINST)
+30 SET ^MDK(704.202,"AS",1,+MDINST)=""
+31 QUIT
