Changeset 623 for WorldVistAEHR/trunk/r/CLINICAL_PROCEDURES-MD/MDHL7MCA.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/CLINICAL_PROCEDURES-MD/MDHL7MCA.m
r613 r623 1 MDHL7MCA ; HOIFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38]2 ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102 3 4 5 6 ; Reference DBIA #10096 for ^%ZOSF calls. 7 EN ; Entry Point for Message Array inMSG8 N MSG 9 K ERRTX 10 S MDERROR=0 11 ;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)12 M MSG=^TMP($J,"MDHL7A") 13 S NUM=1 14 MSH ; Decode MSH 15 K SEG 16 I '$D(MSG(NUM)) G KIL 17 S X=$G(MSG(NUM)),SEG("MSH")=X,MCAPP="" 18 I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7MCXG KIL19 S MCAPP=$P(MSG(NUM),"|",4) I MCAPP="" G KIL 20 S NUM=NUM+1 21 PID ; Check PID 22 S X=$G(MSG(NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7MCX G KIL 23 S SEG("PID")=X 24 S NAM=$P(X,"|",6),MDSSN=$P(X,"|",20) I $L(MDSSN)<9 S MDSSN=$P(X,"|",4)25 S MDSSN=$P(MDSSN,"^",1) I MDSSN'?9N S MDSSN=$TR(MDSSN,"- ","")26 S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0)) 27 I 'DFN S ERRTX="SSN not found" D ^MDHL7MCX G KIL 28 S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1)29 S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")30 S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 31 I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MDHL7MCX G KIL 32 D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) K VA 33 ; If DFN not a medical patient, add DFN to medical patient file 34 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 35 S NUM=NUM+1 36 ; Skip PV1, ORC if necessary 37 LPOBR I $E(MSG(NUM),1,3)'="OBR" S NUM=NUM+1 G LPOBR 38 ;I $E(MSG(NUM),1,3)="ORC" S NUM=NUM+1 39 OBR ; Check OBR 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 PROC 55 56 57 58 P1 59 60 61 KIL 62 63 64 65 66 1 MDHL7MCA ; HIRMFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38] 2 ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004 3 ; Reference DBIA #10035 for DPT calls. 4 ; Reference DBIA #10062 for VADPT calls. 5 ; Reference DBIA #10106 for HL7 calls. 6 EN ; Entry Point for Message Array in MSG 7 N MSG 8 K ERRTX 9 S MDERROR=0 10 ;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) 11 M MSG=^TMP($J,"MDHL7A") 12 S NUM=1 13 MSH ; Decode MSH 14 K SEG 15 I '$D(MSG(NUM)) G KIL 16 S X=$G(MSG(NUM)),SEG("MSH")=X,MCAPP="" 17 I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7MCX G KIL 18 S MCAPP=$P(MSG(NUM),"|",4) I MCAPP="" G KIL 19 S NUM=NUM+1 20 PID ; Check PID 21 S X=$G(MSG(NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7MCX G KIL 22 S SEG("PID")=X 23 S NAM=$P(X,"|",6),MDSSN=$P(X,"|",20) I $L(MDSSN)<9 S MDSSN=$P(X,"|",4) 24 S MDSSN=$P(MDSSN,"^",1) I MDSSN'?9N S MDSSN=$TR(MDSSN,"- ","") 25 S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0)) 26 I 'DFN S ERRTX="SSN not found" D ^MDHL7MCX G KIL 27 S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1) 28 S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 29 S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 30 I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MDHL7MCX G KIL 31 D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) K VA 32 ; If DFN not a medical patient, add DFN to medical patient file 33 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 34 S NUM=NUM+1 35 ; Skip PV1, ORC if necessary 36 LPOBR I $E(MSG(NUM),1,3)'="OBR" S NUM=NUM+1 G LPOBR 37 ;I $E(MSG(NUM),1,3)="ORC" S NUM=NUM+1 38 OBR ; Check OBR 39 W MSG(NUM) 40 S X=$G(MSG(NUM)) I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected" D ^MDHL7MCX G KIL 41 S SEG("OBR")=X 42 S ORIFN=$P(X,"|",3),INST=$P(X,"|",25) I MCAPP="Instrument Manager",INST'="" S MCAPP=INST 43 S ORIFN=$P(X,"|",3),(EXAM,%)=$P(X,"|",5) I EXAM'="" S EXAM=$P(%,"^",2),EXAM2=$P(%,"^",1) I EXAM="" S EXAM=EXAM2 44 S CPT=$P(X,"|",5) I $P(CPT,"^",3)["CPT" S CPT=$P(CPT,"^",1) 45 S DTO="",DATE=$P(X,"|",8) I DATE'="" S:$L(DATE)>14 DATE=$E(DATE,1,14) S DTO=$$FMDATE^HLFNC(DATE) 46 I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7MCX G KIL 47 K SET S SET=DTO_"^"_DFN,NUM=NUM+1,ICNT=0 K IMP 48 ; Go to Application 49 S INST=$O(^MCAR(690.7,"B",MCAPP,0)) I 'INST S X=MCAPP,ERRTX="Invalid Application Code" D ^MDHL7MCX G KIL 50 S MCRTN=$G(^MCAR(690.7,INST,1)) S:MCRTN'["^" MCRTN="^"_MCRTN 51 ; test for existence 52 S X=MCRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MDHL7MCX G KIL 53 D @MCRTN G KIL 54 PROC ; Create Procedure entry in appropriate file (FIL) 55 I $P(SET,"^",1)=""!($P(SET,"^",2)="") Q 56 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 57 Q:DA 58 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) 59 I $D(^MCAR(FIL,DA)) G P1 60 S ^MCAR(FIL,DA,0)=SET S DIK="^MCAR("_FIL_"," D IX1^DIK Q 61 KIL ; Kill Variables 62 K %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,ERRTX,EXAM,EXAM2,EXE,FIL 63 K I,ICNT,ID,IMP,J,K,LBL,LINE,LN,MCAPP,MCRTN,MG,MSG,N,NAM,NEXT,NUM 64 K ORIFN,P,PID,PIEN,S,SEG,SEP,SET,MDSSN,STR,STYP,SUB,TCNT,TXT 65 K UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z1,Z2 66 Q
Note:
See TracChangeset
for help on using the changeset viewer.
