source: FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDWOR.m@ 628

MDWOR ; HOIFO/NCA - Main Routine to Decode HL7 ;5/23/07  10:49
 ;;1.0;CLINICAL PROCEDURES;**14**;Apr 01,2004;Build 20
 ; Reference IA# 2263 [Supported] XPAR calls
 ;               3071 [Subscription] Call $$PKGID^ORX8.
 ;               3468 [Subscription] Call GMRCCP.
 ;               10035 [Supported] Access Patient file DPT
 ;               10040 [Supported] Hospital Location File SC
 ;               10103 [Supported] XLFDT calls
 ;
EN(MDMSG) ; Entry Point for CPRS and pass MSG in MDMSG
 N DFN,MDCON,MDCPROC,MDCANC,MDCANR,MDIFN,MDINST,MDINT,MDFLG,MDL,MDIN,MDINP,MDINST,MDLOC,MDNAM,MDOBC,MDOBX,MDOPRO,MDPROC,MDPAT
 N MDPROV,MDREQ,MDQTIM,MDSINP,MDVSTD,MDX S MDVSTD=""
 S (MDINP,MDFLG,MDCANC,MDOBC)=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)="OBR" D OBR Q
 .I $E(MDX,1,3)="OBX" D:MDOBC<1 OBX Q
 .Q
 I 'MDFLG,'MDCANC 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 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
 S MDINST=$O(^MDD(702,"ACON",MDCON,0)) Q:'MDINST
 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 MDX1,MDFDA,MDIEN,MDIENS,MDERR,MDHL7,MDHOLD,MDSCHD,MDMAXD,MDXY,MDNOW
 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,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)=$S(MDNOW>MDSCHD:MDSCHD,1:MDNOW)
 .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")
 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