MDHL7MCA ; HOIFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38]
;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
; Reference DBIA #10035 for DPT calls.
; Reference DBIA #10062 for VADPT calls.
; Reference DBIA #10106 for HL7 calls.
; Reference DBIA #10096 for ^%ZOSF calls.
EN ; Entry Point for Message Array in MSG
N MSG
K ERRTX
S MDERROR=0
;F I=3:1 X HLNEXT Q:HLQUIT'>0 S MSG(I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S MSG(I,J)=HLNODE(J)
M MSG=^TMP($J,"MDHL7A")
S NUM=1
MSH ; Decode MSH
K SEG
I '$D(MSG(NUM)) G KIL
S X=$G(MSG(NUM)),SEG("MSH")=X,MCAPP=""
I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7MCX G KIL
S MCAPP=$P(MSG(NUM),"|",4) I MCAPP="" G KIL
S NUM=NUM+1
PID ; Check PID
S X=$G(MSG(NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7MCX G KIL
S SEG("PID")=X
S NAM=$P(X,"|",6),MDSSN=$P(X,"|",20) I $L(MDSSN)<9 S MDSSN=$P(X,"|",4)
S MDSSN=$P(MDSSN,"^",1) I MDSSN'?9N S MDSSN=$TR(MDSSN,"- ","")
S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0))
I 'DFN S ERRTX="SSN not found" D ^MDHL7MCX G KIL
S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1)
S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MDHL7MCX G KIL
D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) K VA
; If DFN not a medical patient, add DFN to medical patient file
I '$D(^MCAR(690,DFN)) S ^MCAR(690,DFN,0)=DFN,^MCAR(690,"B",DFN,DFN)="",$P(^MCAR(690,0),U,4)=$P(^MCAR(690,0),U,4)+1 S:$P(^MCAR(690,0),U,3)<DFN $P(^MCAR(690,0),U,3)=DFN
S NUM=NUM+1
; Skip PV1, ORC if necessary
LPOBR I $E(MSG(NUM),1,3)'="OBR" S NUM=NUM+1 G LPOBR
;I $E(MSG(NUM),1,3)="ORC" S NUM=NUM+1
OBR ; Check OBR
S X=$G(MSG(NUM)) I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected" D ^MDHL7MCX G KIL
S SEG("OBR")=X
S ORIFN=$P(X,"|",3),INST=$P(X,"|",25) I MCAPP="Instrument Manager",INST'="" S MCAPP=INST
S ORIFN=$P(X,"|",3),(EXAM,%)=$P(X,"|",5) I EXAM'="" S EXAM=$P(%,"^",2),EXAM2=$P(%,"^",1) I EXAM="" S EXAM=EXAM2
S CPT=$P(X,"|",5) I $P(CPT,"^",3)["CPT" S CPT=$P(CPT,"^",1)
S DTO="",DATE=$P(X,"|",8) I DATE'="" S:$L(DATE)>14 DATE=$E(DATE,1,14) S DTO=$$FMDATE^HLFNC(DATE)
I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7MCX G KIL
K SET S SET=DTO_"^"_DFN,NUM=NUM+1,ICNT=0 K IMP
; Go to Application
S INST=$O(^MCAR(690.7,"B",MCAPP,0)) I 'INST S X=MCAPP,ERRTX="Invalid Application Code" D ^MDHL7MCX G KIL
S MCRTN=$G(^MCAR(690.7,INST,1)) S:MCRTN'["^" MCRTN="^"_MCRTN
; test for existence
S X=MCRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MDHL7MCX G KIL
D @MCRTN G KIL
PROC ; Create Procedure entry in appropriate file (FIL)
I $P(SET,"^",1)=""!($P(SET,"^",2)="") Q
S DA=0 F S DA=$O(^MCAR(FIL,"B",$P(SET,"^",1),DA)) Q:'DA I $P($G(^MCAR(FIL,DA,0)),"^",1,2)=SET Q
Q:DA
P1 L +^MCAR(FIL,0):3 G:'$T P1 S DA=$P(^MCAR(FIL,0),"^",3)+1,$P(^MCAR(FIL,0),"^",3,4)=DA_"^"_DA L -^MCAR(FIL,0)
I $D(^MCAR(FIL,DA)) G P1
S ^MCAR(FIL,DA,0)=SET S DIK="^MCAR("_FIL_"," D IX1^DIK Q
KIL ; Kill Variables
K %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,ERRTX,EXAM,EXAM2,EXE,FIL
K I,ICNT,ID,IMP,J,K,LBL,LINE,LN,MCAPP,MCRTN,MG,MSG,N,NAM,NEXT,NUM
K ORIFN,P,PID,PIEN,S,SEG,SEP,SET,MDSSN,STR,STYP,SUB,TCNT,TXT
K UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z1,Z2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDHL7MCA 3464 printed Dec 13, 2024@01:42:51 Page 2
MDHL7MCA ; HOIFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38]
+1 ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
+2 ; Reference DBIA #10035 for DPT calls.
+3 ; Reference DBIA #10062 for VADPT calls.
+4 ; Reference DBIA #10106 for HL7 calls.
+5 ; Reference DBIA #10096 for ^%ZOSF calls.
EN ; Entry Point for Message Array in MSG
+1 NEW MSG
+2 KILL ERRTX
+3 SET MDERROR=0
+4 ;F I=3:1 X HLNEXT Q:HLQUIT'>0 S MSG(I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S MSG(I,J)=HLNODE(J)
+5 MERGE MSG=^TMP($JOB,"MDHL7A")
+6 SET NUM=1
MSH ; Decode MSH
+1 KILL SEG
+2 IF '$DATA(MSG(NUM))
GOTO KIL
+3 SET X=$GET(MSG(NUM))
SET SEG("MSH")=X
SET MCAPP=""
+4 IF $EXTRACT(X,1,3)'="MSH"
SET ERRTX="MSH not first record"
DO ^MDHL7MCX
GOTO KIL
+5 SET MCAPP=$PIECE(MSG(NUM),"|",4)
IF MCAPP=""
GOTO KIL
+6 SET NUM=NUM+1
PID ; Check PID
+1 SET X=$GET(MSG(NUM))
IF $EXTRACT(X,1,3)'="PID"
SET ERRTX="PID not second record"
DO ^MDHL7MCX
GOTO KIL
+2 SET SEG("PID")=X
+3 SET NAM=$PIECE(X,"|",6)
SET MDSSN=$PIECE(X,"|",20)
IF $LENGTH(MDSSN)<9
SET MDSSN=$PIECE(X,"|",4)
+4 SET MDSSN=$PIECE(MDSSN,"^",1)
IF MDSSN'?9N
SET MDSSN=$TRANSLATE(MDSSN,"- ","")
+5 if MDSSN'?9N
SET MDSSN=" "
SET DFN=$ORDER(^DPT("SSN",MDSSN,0))
+6 IF 'DFN
SET ERRTX="SSN not found"
DO ^MDHL7MCX
GOTO KIL
+7 SET Z1=$PIECE($GET(^DPT(DFN,0)),",",1)
SET Z2=$PIECE(NAM,"^",1)
+8 SET Z1=$TRANSLATE(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+9 SET Z2=$TRANSLATE(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+10 IF $EXTRACT(Z1,1,3)'=$EXTRACT(Z2,1,3)
SET ERRTX="Last Name MisMatch"
DO ^MDHL7MCX
GOTO KIL
+11 DO PID^VADPT6
SET PID=$GET(VA("PID"))
SET BID=$GET(VA("BID"))
KILL VA
+12 ; If DFN not a medical patient, add DFN to medical patient file
+13 IF '$DATA(^MCAR(690,DFN))
SET ^MCAR(690,DFN,0)=DFN
SET ^MCAR(690,"B",DFN,DFN)=""
SET $PIECE(^MCAR(690,0),U,4)=$PIECE(^MCAR(690,0),U,4)+1
if $PIECE(^MCAR(690,0),U,3)<DFN
SET $PIECE(^MCAR(690,0),U,3)=DFN
+14 SET NUM=NUM+1
+15 ; Skip PV1, ORC if necessary
LPOBR IF $EXTRACT(MSG(NUM),1,3)'="OBR"
SET NUM=NUM+1
GOTO LPOBR
+1 ;I $E(MSG(NUM),1,3)="ORC" S NUM=NUM+1
OBR ; Check OBR
+1 SET X=$GET(MSG(NUM))
IF $EXTRACT(X,1,3)'="OBR"
SET ERRTX="OBR not found when expected"
DO ^MDHL7MCX
GOTO KIL
+2 SET SEG("OBR")=X
+3 SET ORIFN=$PIECE(X,"|",3)
SET INST=$PIECE(X,"|",25)
IF MCAPP="Instrument Manager"
IF INST'=""
SET MCAPP=INST
+4 SET ORIFN=$PIECE(X,"|",3)
SET (EXAM,%)=$PIECE(X,"|",5)
IF EXAM'=""
SET EXAM=$PIECE(%,"^",2)
SET EXAM2=$PIECE(%,"^",1)
IF EXAM=""
SET EXAM=EXAM2
+5 SET CPT=$PIECE(X,"|",5)
IF $PIECE(CPT,"^",3)["CPT"
SET CPT=$PIECE(CPT,"^",1)
+6 SET DTO=""
SET DATE=$PIECE(X,"|",8)
IF DATE'=""
if $LENGTH(DATE)>14
SET DATE=$EXTRACT(DATE,1,14)
SET DTO=$$FMDATE^HLFNC(DATE)
+7 IF DTO=""
SET ERRTX="Missing required Date/Time of Procedure in OBR"
DO ^MDHL7MCX
GOTO KIL
+8 KILL SET
SET SET=DTO_"^"_DFN
SET NUM=NUM+1
SET ICNT=0
KILL IMP
+9 ; Go to Application
+10 SET INST=$ORDER(^MCAR(690.7,"B",MCAPP,0))
IF 'INST
SET X=MCAPP
SET ERRTX="Invalid Application Code"
DO ^MDHL7MCX
GOTO KIL
+11 SET MCRTN=$GET(^MCAR(690.7,INST,1))
if MCRTN'["^"
SET MCRTN="^"_MCRTN
+12 ; test for existence
+13 SET X=MCRTN
if X["^"
SET X=$PIECE(X,"^",2)
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET ERRTX="Processing routine not found"
DO ^MDHL7MCX
GOTO KIL
+14 DO @MCRTN
GOTO KIL
PROC ; Create Procedure entry in appropriate file (FIL)
+1 IF $PIECE(SET,"^",1)=""!($PIECE(SET,"^",2)="")
QUIT
+2 SET DA=0
FOR
SET DA=$ORDER(^MCAR(FIL,"B",$PIECE(SET,"^",1),DA))
if 'DA
QUIT
IF $PIECE($GET(^MCAR(FIL,DA,0)),"^",1,2)=SET
QUIT
+3 if DA
QUIT
P1 LOCK +^MCAR(FIL,0):3
if '$TEST
GOTO P1
SET DA=$PIECE(^MCAR(FIL,0),"^",3)+1
SET $PIECE(^MCAR(FIL,0),"^",3,4)=DA_"^"_DA
LOCK -^MCAR(FIL,0)
+1 IF $DATA(^MCAR(FIL,DA))
GOTO P1
+2 SET ^MCAR(FIL,DA,0)=SET
SET DIK="^MCAR("_FIL_","
DO IX1^DIK
QUIT
KIL ; Kill Variables
+1 KILL %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,ERRTX,EXAM,EXAM2,EXE,FIL
+2 KILL I,ICNT,ID,IMP,J,K,LBL,LINE,LN,MCAPP,MCRTN,MG,MSG,N,NAM,NEXT,NUM
+3 KILL ORIFN,P,PID,PIEN,S,SEG,SEP,SET,MDSSN,STR,STYP,SUB,TCNT,TXT
+4 KILL UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z1,Z2
+5 QUIT
