| [613] | 1 | MCAR7A ; HIRMFO/REL-Main Routine to Decode HL7 ;5/26/00 09:43
|
|---|
| 2 | ;;2.3;Medicine;**24**;09/13/1996
|
|---|
| 3 | EN ; Entry Point for Message Array in MSG
|
|---|
| 4 | ; Reference DBIA #10035 for DPT calls.
|
|---|
| 5 | K MSG,ERRTX
|
|---|
| 6 | F I=1: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)
|
|---|
| 7 | S NUM=1
|
|---|
| 8 | MSH ; Decode MSH
|
|---|
| 9 | K SEG
|
|---|
| 10 | I '$D(MSG(NUM)) G KIL
|
|---|
| 11 | S X=$G(MSG(NUM)),SEG("MSH")=X,MCAPP=""
|
|---|
| 12 | I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MCAR7X G KIL
|
|---|
| 13 | S MCAPP=$P(MSG(NUM),"|",4) I MCAPP="" G KIL
|
|---|
| 14 | S NUM=NUM+1
|
|---|
| 15 | PID ; Check PID
|
|---|
| 16 | S X=$G(MSG(NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MCAR7X G KIL
|
|---|
| 17 | S SEG("PID")=X
|
|---|
| 18 | S NAM=$P(X,"|",6),SSN=$P(X,"|",20) I $L(SSN)<9 S SSN=$P(X,"|",4)
|
|---|
| 19 | S SSN=$P(SSN,"^",1) I SSN'?9N S SSN=$TR(SSN,"- ","")
|
|---|
| 20 | S:SSN'?9N SSN=" " S DFN=$O(^DPT("SSN",SSN,0))
|
|---|
| 21 | I 'DFN S ERRTX="SSN not found" D ^MCAR7X G KIL
|
|---|
| 22 | S Z1=$P($G(^DPT(DFN,0)),",",1),Z2=$P(NAM,"^",1)
|
|---|
| 23 | S Z1=$TR(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
|---|
| 24 | S Z2=$TR(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
|---|
| 25 | I $E(Z1,1,3)'=$E(Z2,1,3) S ERRTX="Last Name MisMatch" D ^MCAR7X G KIL
|
|---|
| 26 | D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) K VA
|
|---|
| 27 | ; If DFN not a medical patient, add DFN to medical patient file
|
|---|
| 28 | 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
|
|---|
| 29 | S NUM=NUM+1
|
|---|
| 30 | ; Skip PV1, ORC if necessary
|
|---|
| 31 | I $E(MSG(NUM),1,3)="PV1" S NUM=NUM+1
|
|---|
| 32 | I $E(MSG(NUM),1,3)="ORC" S NUM=NUM+1
|
|---|
| 33 | OBR ; Check OBR
|
|---|
| 34 | S X=$G(MSG(NUM)) I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected" D ^MCAR7X G KIL
|
|---|
| 35 | S SEG("OBR")=X
|
|---|
| 36 | S ORIFN=$P(X,"|",3),INST=$P(X,"|",25) I MCAPP="Instrument Manager",INST'="" S MCAPP=INST
|
|---|
| 37 | S ORIFN=$P(X,"|",3),(EXAM,%)=$P(X,"|",5) I EXAM'="" S EXAM=$P(%,"^",2),EXAM2=$P(%,"^",1) I EXAM="" S EXAM=EXAM2
|
|---|
| 38 | S CPT=$P(X,"|",5) I $P(CPT,"^",3)["CPT" S CPT=$P(CPT,"^",1)
|
|---|
| 39 | S DTO="",DATE=$P(X,"|",8) I DATE'="" S DTO=$$FMDATE^HLFNC(DATE)
|
|---|
| 40 | I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MCAR7X G KIL
|
|---|
| 41 | K SET S SET=DTO_"^"_DFN,NUM=NUM+1,ICNT=0 K IMP
|
|---|
| 42 | ; Go to Application
|
|---|
| 43 | S INST=$O(^MCAR(690.7,"B",MCAPP,0)) I 'INST S X=MCAPP,ERRTX="Invalid Application Code" D ^MCAR7X G KIL
|
|---|
| 44 | S MCRTN=$G(^MCAR(690.7,INST,1)) S:MCRTN'["^" MCRTN="^"_MCRTN
|
|---|
| 45 | ; test for existence
|
|---|
| 46 | S X=MCRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MCAR7X G KIL
|
|---|
| 47 | D @MCRTN G KIL
|
|---|
| 48 | PROC ; Create Procedure entry in appropriate file (FIL)
|
|---|
| 49 | I $P(SET,"^",1)=""!($P(SET,"^",2)="") Q
|
|---|
| 50 | 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
|
|---|
| 51 | Q:DA
|
|---|
| 52 | 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)
|
|---|
| 53 | I $D(^MCAR(FIL,DA)) G P1
|
|---|
| 54 | S ^MCAR(FIL,DA,0)=SET S DIK="^MCAR("_FIL_"," D IX1^DIK Q
|
|---|
| 55 | KIL ; Kill Variables
|
|---|
| 56 | K %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,ERRTX,EXAM,EXAM2,EXE,FIL
|
|---|
| 57 | K I,ICNT,ID,IMP,J,K,LBL,LINE,LN,MCAPP,MCRTN,MG,MSG,N,NAM,NEXT,NUM
|
|---|
| 58 | K ORIFN,P,PID,PIEN,S,SEG,SEP,SET,SSN,STR,STYP,SUB,TCNT,TXT
|
|---|
| 59 | K UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z1,Z2 Q
|
|---|
