MDHL7A ; HOIFO/WAA - Routine to Decode HL7 for CP ;05/21/09 15:57
;;1.0;CLINICAL PROCEDURES;**6,11,21**;Apr 01, 2004;Build 30
; Reference DBIA #10035 [Supported] for DPT calls.
; Reference DBIA #10106 [Supported] for HLFNC calls.
; Reference DBIA #10062 [Supported] for VADPT6 calls.
; Reference DBIA #2701 [Supported] for MPIF001 calls
; Reference DBIA #10096 [Supported] for ^%ZOSF calls
EN ; [Procedure] Entry Point for Message Array in MSG
N %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,DZ,ERRTX,EXAM,EXE,MDFLAG,FIL
N I,ICNT,ID,IMP,J,K,LBL,LINO,LINE,LN,MDAPP,MDRTN,MG,MSG,N,NAM,NEXT,NUM
N ORIFN,P,PID,PIEN,S,SEG,SET,SEP,MDSSN,STR,STYP,SUB,TCNT,TXT,UNIQ,SEC
N UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z,ZZ,Z1,Z2,MDERROR
N ECODE,MDIEN,MDOBX,NUMZ,PNAM,ZCODE,MDDEV,MDD702,DEVNAME,DEVIEN,MDQFLG
N MDIORD,MDHORD
K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7"),^TMP($J,"MDHL7A1")
S MDFLAG=0,MDERROR=0,MDQFLG=0,MDHORD=""
Q:$G(HLMTIENS)=""
S ^TMP($J,"MDHL7A1")=""
S HLREST="^TMP($J,""MDHL7A1"")"
S X=$$MSGIEN^MDHL7U3(HLMTIENS,HLREST) ; This code is to convert the HL7 Message **6**
I $P(X,U)=0 D Q
. S DEVIEN=0,ECODE=0
. S ERRTX=$P(X,U,2)
. D ^MDHL7X
. Q
I $P(X,U)=1 D XVERT^MDHL7U3("MDHL7A1","MDHL7A")
K HLNODE,^TMP($J,"MDHL7A1")
;
EN2 ; [Procedure] No Description
S (DEVIEN,DEVNAME)="",I=0
F I=1:1 S X=$G(^TMP($J,"MDHL7A",I)) Q:X="" Q:$E(X,1,3)="OBX" D
. S:$E(X,1,3)="MSH" DEVNAME=$P(X,"|",4)
. I DEVNAME="",HLREC("SFN")'="" S DEVNAME=HLREC("SFN")
. I $E(X,1,3)="MSH",DEVNAME'="Instrument Manager" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0))
. I $E(X,1,3)="OBR" D
.. I DEVNAME="Instrument Manager" D
... S DEVNAME=$P(X,"|",25)
... Q
.. S MDIORD=$P(X,"|",4)
.. S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD))
.. I MDD702<1 S MDD702="" Q
.. I MDD702>0 D ;Validate the entry from 702 is good.
... I $G(^MDD(702,MDD702,0))="" S MDD702="" Q
... S DEVIEN=$$GET1^DIQ(702,MDD702,.11,"I")
... I DEVIEN<1 S DEVIEN="" ; No device defined
... Q
.. Q
. Q
I DEVIEN="",DEVNAME'="" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0))
I DEVNAME="" S ERRTX="Invalid device Code" D ^MDHL7X Q
I DEVIEN="" S ERRTX="Invalid device entry "_DEVNAME D ^MDHL7X Q
S ZCODE=$P($G(^MDS(702.09,DEVIEN,.1)),"^",2)
S ECODE=0,INST=DEVIEN,MDAPP=DEVNAME
I 'INST S ERRTX="Invalid Application Code" D ^MDHL7X Q
D INST^MDHL7U2(DEVIEN,.ECODE) I 'ECODE D Q
. S ERRTX="Device Error" D ^MDHL7X
. Q
I (ZCODE="M")!(ZCODE="B") D Q:MDERROR Q:ZCODE="M" ;
. S MDFLAG=1,MDERROR=0 ; Tell Medicine that CP is talking to HL7
. D ^MDHL7MCA ; Run the Medicine routines
. Q:MDERROR ; Medicine found an error and sent an error back
. Q
S NUMZ=$O(^TMP($J,"MDHL7A",""),-1)
S NUM=0,MDOBX=0
F NUM=1:1:NUMZ D Q:$G(ERRTX)'=""
. S LINO=^TMP($J,"MDHL7A",NUM)
. S SEC=$P(LINO,"|")
. I SEC="MSH" D MSH Q
. I SEC="PID" D PID Q
. I SEC="OBR" D OBR Q
. I SEC="PV1" Q
. I SEC="ORC" Q
. I SEC="OBX" S MDOBX=1 Q
. Q
Q:$G(ERRTX)'=""
I 'MDOBX S ERRTX="OBX not found when expected" D ^MDHL7X Q
D OBX
D STATUS(MDIEN,"P")
K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7")
Q
STATUS(DA,STAT) ; Update the status of the report in 703.1
Q:$G(ERRTX)'=""
S $P(^MDD(703.1,DA,0),U,9)=STAT
S DIK="^MDD(703.1," D IX1^DIK
Q
IM ;Instrument Manager Interface
Q:DEVNAME'="Instrument Manager"
I $E(X,1,3)'="OBR" Q
S DEVNAME=$P(X,"|",25)
S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0))
Q
;
MSH ; [Procedure] Decode MSH
N SEG
I '$D(^TMP($J,"MDHL7A",NUM)) Q
S X=$G(^TMP($J,"MDHL7A",NUM)),SEG("MSH")=X
I $E(X,1,3)'="MSH" S ERRTX="MSH not first record" D ^MDHL7X Q
Q
;
OBR ; [Procedure] Check OBR
Q:$G(MDHORD)'=""
N MDGMRC
S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected" D ^MDHL7X Q
S SEG("OBR")=X
S MDIORD=$P(X,"|",4)
S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD)) S:MDHORD="" MDHORD=MDD702
S:MDD702="" MDD702=MDHORD
I MDD702'="" S MDD702=$$CHK^MDNCHK(MDD702) ; PATCH 11
S ORIFN=$P(X,"|",3),(EXAM,%)=$P(X,"|",5) I EXAM'="" S EXAM=$P(%,"^",2) I EXAM="" S EXAM=$P(%,"^",1)
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)
; vvv== Added to address the issues of mismatch
I $G(MDD702)>0 I DFN'=$$GET1^DIQ(702,MDD702,.01,"I") S ERRTX="Patient name Mismatch. Name in PID doesn't match the name in the CP Order #"_MDD702_"." D ^MDHL7X Q
I $G(MDD702)>0 I MDDOB'=$$GET1^DIQ(2,DFN,.03,"I") S ERRTX="Patient DOB Mismatch. DOB in PID doesn't match the DOB in the CP Order #"_MDD702_"." D ^MDHL7X Q
I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7X Q
;;S UNIQ=$TR($H,",","-")
S UNIQ=$$NEWID(DFN,DATE,INST,$G(MDD702),HLMTIEN)
I +UNIQ="-1" S ERRTX="Unable to Create or Lock 703.1" D ^MDHL7X Q
S MDIEN=$P(UNIQ,"^",1) ; Got the IEN for 703.1
N SET S SET=DTO_"^"_$P(UNIQ,U,2),ICNT=0 N IMP
S MDRTN=$P($G(^MDS(702.09,INST,.1)),"^",1) S:MDRTN'["^" MDRTN="^"_MDRTN
S X=MDRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MDHL7X Q ; IA %10096
D CPTICD^MDHL7U3(X,MDIEN) ; Update CPT and ICD9
D PHY^MDHL7U3(X,MDIEN) ; Get Doc who did the procedure.
Q
;
PID ; [Procedure] Check PID
S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7X Q
S SEG("PID")=X
S MDDOB=$P(X,"|",8) I MDDOB'="" S MDDOB=($E(MDDOB,1,4)-1700)_$E(MDDOB,5,8)
I $L($P(X,"|",4))'<16 D I +DFN=-1 Q
. N ICN
. S ICN=$P(X,"|",4)
. S DFN=$$GETDFN^MPIF001(ICN)
. I +DFN=-1 S ERRTX=$P(DFN,U,2)
. D MDSSN I DFN<1 S ERRTX="SSN not found" D ^MDHL7X Q
. I DFN>0 K ERRTX
. S MDSSN=$$GET1^DIQ(2,DFN,.09,"I") I MDSSN="" S MDSSN=" ",DFN=0
. Q
E D MDSSN
I 'DFN S ERRTX="SSN not found" D ^MDHL7X Q
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 ^MDHL7X Q
S PNAM=$TR(NAM,"^",",")
D PID^VADPT6 S PID=$G(VA("PID")),BID=$G(VA("BID")) N VA
Q
MDSSN ; This subroutine is to match up the SSN for a patient.
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,"- ","")
I $E(MDSSN,$L(MDSSN))="P" S MDSSN=$E(MDSSN,1,9)
S:MDSSN'?9N MDSSN=" " S DFN=$O(^DPT("SSN",MDSSN,0))
I 'DFN S DFN=$O(^DPT("SSN",MDSSN_"P",0))
Q
;
OBX ; [Observation]
D @MDRTN
Q
NEWID(DFN,DATE,INST,MDD702,HLMTIEN) ; Generate a new entry and ID of 703.1
N NEWID,MDFDA,MDIEN,MDNO,MDRECI
S NEWID=$TR($H,",","-") ; Create inital ID
L +(^MDD(703.1,"B")):60 E Q "-1"
;^^--- Unable to get a lock in the file
F Q:'$D(^MDD(703.1,"B",NEWID)) H 1 S NEWID=$TR($H,",","-")
;^^--- Search to create a new ID if current ID is in use
S MDFDA(703.1,"+1,",.01)=NEWID
S MDFDA(703.1,"+1,",.02)=DFN
S MDFDA(703.1,"+1,",.03)=$$HL7TFM^MDHL7U(DATE)
S MDFDA(703.1,"+1,",.04)=INST
S MDFDA(703.1,"+1,",.05)=MDD702
S MDFDA(703.1,"+1,",.06)=HLMTIEN
D UPDATE^DIE("","MDFDA","MDIEN")
L -(^MDD(703.1,"B"))
I $G(MDIEN(1))>0 D Q MDIEN(1)_U_NEWID
. S ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0"
. S MDRECI=+MDIEN(1)
. S MDNO=$$NTIU^MDRPCW1(+MDD702,+MDRECI)
. Q
; ^^--- Create Subfile and quit
Q "-1" ; Unable to create file
;
PROC ; [Procedure] Create report entry in file (703.1)
D PROC^MDHL7U
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDHL7A 7510 printed Dec 13, 2024@01:42:43 Page 2
MDHL7A ; HOIFO/WAA - Routine to Decode HL7 for CP ;05/21/09 15:57
+1 ;;1.0;CLINICAL PROCEDURES;**6,11,21**;Apr 01, 2004;Build 30
+2 ; Reference DBIA #10035 [Supported] for DPT calls.
+3 ; Reference DBIA #10106 [Supported] for HLFNC calls.
+4 ; Reference DBIA #10062 [Supported] for VADPT6 calls.
+5 ; Reference DBIA #2701 [Supported] for MPIF001 calls
+6 ; Reference DBIA #10096 [Supported] for ^%ZOSF calls
EN ; [Procedure] Entry Point for Message Array in MSG
+1 NEW %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,DZ,ERRTX,EXAM,EXE,MDFLAG,FIL
+2 NEW I,ICNT,ID,IMP,J,K,LBL,LINO,LINE,LN,MDAPP,MDRTN,MG,MSG,N,NAM,NEXT,NUM
+3 NEW ORIFN,P,PID,PIEN,S,SEG,SET,SEP,MDSSN,STR,STYP,SUB,TCNT,TXT,UNIQ,SEC
+4 NEW UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z,ZZ,Z1,Z2,MDERROR
+5 NEW ECODE,MDIEN,MDOBX,NUMZ,PNAM,ZCODE,MDDEV,MDD702,DEVNAME,DEVIEN,MDQFLG
+6 NEW MDIORD,MDHORD
+7 KILL ^TMP($JOB,"MDHL7A"),^TMP($JOB,"MDHL7"),^TMP($JOB,"MDHL7A1")
+8 SET MDFLAG=0
SET MDERROR=0
SET MDQFLG=0
SET MDHORD=""
+9 if $GET(HLMTIENS)=""
QUIT
+10 SET ^TMP($JOB,"MDHL7A1")=""
+11 SET HLREST="^TMP($J,""MDHL7A1"")"
+12 ; This code is to convert the HL7 Message **6**
SET X=$$MSGIEN^MDHL7U3(HLMTIENS,HLREST)
+13 IF $PIECE(X,U)=0
Begin DoDot:1
+14 SET DEVIEN=0
SET ECODE=0
+15 SET ERRTX=$PIECE(X,U,2)
+16 DO ^MDHL7X
+17 QUIT
End DoDot:1
QUIT
+18 IF $PIECE(X,U)=1
DO XVERT^MDHL7U3("MDHL7A1","MDHL7A")
+19 KILL HLNODE,^TMP($JOB,"MDHL7A1")
+20 ;
EN2 ; [Procedure] No Description
+1 SET (DEVIEN,DEVNAME)=""
SET I=0
+2 FOR I=1:1
SET X=$GET(^TMP($JOB,"MDHL7A",I))
if X=""
QUIT
if $EXTRACT(X,1,3)="OBX"
QUIT
Begin DoDot:1
+3 if $EXTRACT(X,1,3)="MSH"
SET DEVNAME=$PIECE(X,"|",4)
+4 IF DEVNAME=""
IF HLREC("SFN")'=""
SET DEVNAME=HLREC("SFN")
+5 IF $EXTRACT(X,1,3)="MSH"
IF DEVNAME'="Instrument Manager"
SET DEVIEN=$ORDER(^MDS(702.09,"B",DEVNAME,0))
+6 IF $EXTRACT(X,1,3)="OBR"
Begin DoDot:2
+7 IF DEVNAME="Instrument Manager"
Begin DoDot:3
+8 SET DEVNAME=$PIECE(X,"|",25)
+9 QUIT
End DoDot:3
+10 SET MDIORD=$PIECE(X,"|",4)
+11 SET MDD702=$SELECT(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD))
+12 IF MDD702<1
SET MDD702=""
QUIT
+13 ;Validate the entry from 702 is good.
IF MDD702>0
Begin DoDot:3
+14 IF $GET(^MDD(702,MDD702,0))=""
SET MDD702=""
QUIT
+15 SET DEVIEN=$$GET1^DIQ(702,MDD702,.11,"I")
+16 ; No device defined
IF DEVIEN<1
SET DEVIEN=""
+17 QUIT
End DoDot:3
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 IF DEVIEN=""
IF DEVNAME'=""
SET DEVIEN=$ORDER(^MDS(702.09,"B",DEVNAME,0))
+21 IF DEVNAME=""
SET ERRTX="Invalid device Code"
DO ^MDHL7X
QUIT
+22 IF DEVIEN=""
SET ERRTX="Invalid device entry "_DEVNAME
DO ^MDHL7X
QUIT
+23 SET ZCODE=$PIECE($GET(^MDS(702.09,DEVIEN,.1)),"^",2)
+24 SET ECODE=0
SET INST=DEVIEN
SET MDAPP=DEVNAME
+25 IF 'INST
SET ERRTX="Invalid Application Code"
DO ^MDHL7X
QUIT
+26 DO INST^MDHL7U2(DEVIEN,.ECODE)
IF 'ECODE
Begin DoDot:1
+27 SET ERRTX="Device Error"
DO ^MDHL7X
+28 QUIT
End DoDot:1
QUIT
+29 ;
IF (ZCODE="M")!(ZCODE="B")
Begin DoDot:1
+30 ; Tell Medicine that CP is talking to HL7
SET MDFLAG=1
SET MDERROR=0
+31 ; Run the Medicine routines
DO ^MDHL7MCA
+32 ; Medicine found an error and sent an error back
if MDERROR
QUIT
+33 QUIT
End DoDot:1
if MDERROR
QUIT
if ZCODE="M"
QUIT
+34 SET NUMZ=$ORDER(^TMP($JOB,"MDHL7A",""),-1)
+35 SET NUM=0
SET MDOBX=0
+36 FOR NUM=1:1:NUMZ
Begin DoDot:1
+37 SET LINO=^TMP($JOB,"MDHL7A",NUM)
+38 SET SEC=$PIECE(LINO,"|")
+39 IF SEC="MSH"
DO MSH
QUIT
+40 IF SEC="PID"
DO PID
QUIT
+41 IF SEC="OBR"
DO OBR
QUIT
+42 IF SEC="PV1"
QUIT
+43 IF SEC="ORC"
QUIT
+44 IF SEC="OBX"
SET MDOBX=1
QUIT
+45 QUIT
End DoDot:1
if $GET(ERRTX)'=""
QUIT
+46 if $GET(ERRTX)'=""
QUIT
+47 IF 'MDOBX
SET ERRTX="OBX not found when expected"
DO ^MDHL7X
QUIT
+48 DO OBX
+49 DO STATUS(MDIEN,"P")
+50 KILL ^TMP($JOB,"MDHL7A"),^TMP($JOB,"MDHL7")
+51 QUIT
STATUS(DA,STAT) ; Update the status of the report in 703.1
+1 if $GET(ERRTX)'=""
QUIT
+2 SET $PIECE(^MDD(703.1,DA,0),U,9)=STAT
+3 SET DIK="^MDD(703.1,"
DO IX1^DIK
+4 QUIT
IM ;Instrument Manager Interface
+1 if DEVNAME'="Instrument Manager"
QUIT
+2 IF $EXTRACT(X,1,3)'="OBR"
QUIT
+3 SET DEVNAME=$PIECE(X,"|",25)
+4 SET DEVIEN=$ORDER(^MDS(702.09,"B",DEVNAME,0))
+5 QUIT
+6 ;
MSH ; [Procedure] Decode MSH
+1 NEW SEG
+2 IF '$DATA(^TMP($JOB,"MDHL7A",NUM))
QUIT
+3 SET X=$GET(^TMP($JOB,"MDHL7A",NUM))
SET SEG("MSH")=X
+4 IF $EXTRACT(X,1,3)'="MSH"
SET ERRTX="MSH not first record"
DO ^MDHL7X
QUIT
+5 QUIT
+6 ;
OBR ; [Procedure] Check OBR
+1 if $GET(MDHORD)'=""
QUIT
+2 NEW MDGMRC
+3 SET X=$GET(^TMP($JOB,"MDHL7A",NUM))
IF $EXTRACT(X,1,3)'="OBR"
SET ERRTX="OBR not found when expected"
DO ^MDHL7X
QUIT
+4 SET SEG("OBR")=X
+5 SET MDIORD=$PIECE(X,"|",4)
+6 SET MDD702=$SELECT(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD))
if MDHORD=""
SET MDHORD=MDD702
+7 if MDD702=""
SET MDD702=MDHORD
+8 ; PATCH 11
IF MDD702'=""
SET MDD702=$$CHK^MDNCHK(MDD702)
+9 SET ORIFN=$PIECE(X,"|",3)
SET (EXAM,%)=$PIECE(X,"|",5)
IF EXAM'=""
SET EXAM=$PIECE(%,"^",2)
IF EXAM=""
SET EXAM=$PIECE(%,"^",1)
+10 SET CPT=$PIECE(X,"|",5)
IF $PIECE(CPT,"^",3)["CPT"
SET CPT=$PIECE(CPT,"^",1)
+11 SET DTO=""
SET DATE=$PIECE(X,"|",8)
IF DATE'=""
if $LENGTH(DATE)>14
SET DATE=$EXTRACT(DATE,1,14)
SET DTO=$$FMDATE^HLFNC(DATE)
+12 ; vvv== Added to address the issues of mismatch
+13 IF $GET(MDD702)>0
IF DFN'=$$GET1^DIQ(702,MDD702,.01,"I")
SET ERRTX="Patient name Mismatch. Name in PID doesn't match the name in the CP Order #"_MDD702_"."
DO ^MDHL7X
QUIT
+14 IF $GET(MDD702)>0
IF MDDOB'=$$GET1^DIQ(2,DFN,.03,"I")
SET ERRTX="Patient DOB Mismatch. DOB in PID doesn't match the DOB in the CP Order #"_MDD702_"."
DO ^MDHL7X
QUIT
+15 IF DTO=""
SET ERRTX="Missing required Date/Time of Procedure in OBR"
DO ^MDHL7X
QUIT
+16 ;;S UNIQ=$TR($H,",","-")
+17 SET UNIQ=$$NEWID(DFN,DATE,INST,$GET(MDD702),HLMTIEN)
+18 IF +UNIQ="-1"
SET ERRTX="Unable to Create or Lock 703.1"
DO ^MDHL7X
QUIT
+19 ; Got the IEN for 703.1
SET MDIEN=$PIECE(UNIQ,"^",1)
+20 NEW SET
SET SET=DTO_"^"_$PIECE(UNIQ,U,2)
SET ICNT=0
NEW IMP
+21 SET MDRTN=$PIECE($GET(^MDS(702.09,INST,.1)),"^",1)
if MDRTN'["^"
SET MDRTN="^"_MDRTN
+22 ; IA %10096
SET X=MDRTN
if X["^"
SET X=$PIECE(X,"^",2)
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET ERRTX="Processing routine not found"
DO ^MDHL7X
QUIT
+23 ; Update CPT and ICD9
DO CPTICD^MDHL7U3(X,MDIEN)
+24 ; Get Doc who did the procedure.
DO PHY^MDHL7U3(X,MDIEN)
+25 QUIT
+26 ;
PID ; [Procedure] Check PID
+1 SET X=$GET(^TMP($JOB,"MDHL7A",NUM))
IF $EXTRACT(X,1,3)'="PID"
SET ERRTX="PID not second record"
DO ^MDHL7X
QUIT
+2 SET SEG("PID")=X
+3 SET MDDOB=$PIECE(X,"|",8)
IF MDDOB'=""
SET MDDOB=($EXTRACT(MDDOB,1,4)-1700)_$EXTRACT(MDDOB,5,8)
+4 IF $LENGTH($PIECE(X,"|",4))'<16
Begin DoDot:1
+5 NEW ICN
+6 SET ICN=$PIECE(X,"|",4)
+7 SET DFN=$$GETDFN^MPIF001(ICN)
+8 IF +DFN=-1
SET ERRTX=$PIECE(DFN,U,2)
+9 DO MDSSN
IF DFN<1
SET ERRTX="SSN not found"
DO ^MDHL7X
QUIT
+10 IF DFN>0
KILL ERRTX
+11 SET MDSSN=$$GET1^DIQ(2,DFN,.09,"I")
IF MDSSN=""
SET MDSSN=" "
SET DFN=0
+12 QUIT
End DoDot:1
IF +DFN=-1
QUIT
+13 IF '$TEST
DO MDSSN
+14 IF 'DFN
SET ERRTX="SSN not found"
DO ^MDHL7X
QUIT
+15 SET Z1=$PIECE($GET(^DPT(DFN,0)),",",1)
SET Z2=$PIECE(NAM,"^",1)
+16 SET Z1=$TRANSLATE(Z1,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+17 SET Z2=$TRANSLATE(Z2,"abcdefghijklmnopqrstuvwxyz- '","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+18 IF $EXTRACT(Z1,1,3)'=$EXTRACT(Z2,1,3)
SET ERRTX="Last Name MisMatch"
DO ^MDHL7X
QUIT
+19 SET PNAM=$TRANSLATE(NAM,"^",",")
+20 DO PID^VADPT6
SET PID=$GET(VA("PID"))
SET BID=$GET(VA("BID"))
NEW VA
+21 QUIT
MDSSN ; This subroutine is to match up the SSN for a patient.
+1 SET NAM=$PIECE(X,"|",6)
SET MDSSN=$PIECE(X,"|",20)
IF $LENGTH(MDSSN)<9
SET MDSSN=$PIECE(X,"|",4)
+2 SET MDSSN=$PIECE(MDSSN,"^",1)
IF MDSSN'?9N
SET MDSSN=$TRANSLATE(MDSSN,"- ","")
+3 IF $EXTRACT(MDSSN,$LENGTH(MDSSN))="P"
SET MDSSN=$EXTRACT(MDSSN,1,9)
+4 if MDSSN'?9N
SET MDSSN=" "
SET DFN=$ORDER(^DPT("SSN",MDSSN,0))
+5 IF 'DFN
SET DFN=$ORDER(^DPT("SSN",MDSSN_"P",0))
+6 QUIT
+7 ;
OBX ; [Observation]
+1 DO @MDRTN
+2 QUIT
NEWID(DFN,DATE,INST,MDD702,HLMTIEN) ; Generate a new entry and ID of 703.1
+1 NEW NEWID,MDFDA,MDIEN,MDNO,MDRECI
+2 ; Create inital ID
SET NEWID=$TRANSLATE($HOROLOG,",","-")
+3 LOCK +(^MDD(703.1,"B")):60
IF '$TEST
QUIT "-1"
+4 ;^^--- Unable to get a lock in the file
+5 FOR
if '$DATA(^MDD(703.1,"B",NEWID))
QUIT
HANG 1
SET NEWID=$TRANSLATE($HOROLOG,",","-")
+6 ;^^--- Search to create a new ID if current ID is in use
+7 SET MDFDA(703.1,"+1,",.01)=NEWID
+8 SET MDFDA(703.1,"+1,",.02)=DFN
+9 SET MDFDA(703.1,"+1,",.03)=$$HL7TFM^MDHL7U(DATE)
+10 SET MDFDA(703.1,"+1,",.04)=INST
+11 SET MDFDA(703.1,"+1,",.05)=MDD702
+12 SET MDFDA(703.1,"+1,",.06)=HLMTIEN
+13 DO UPDATE^DIE("","MDFDA","MDIEN")
+14 LOCK -(^MDD(703.1,"B"))
+15 IF $GET(MDIEN(1))>0
Begin DoDot:1
+16 SET ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0"
+17 SET MDRECI=+MDIEN(1)
+18 SET MDNO=$$NTIU^MDRPCW1(+MDD702,+MDRECI)
+19 QUIT
End DoDot:1
QUIT MDIEN(1)_U_NEWID
+20 ; ^^--- Create Subfile and quit
+21 ; Unable to create file
QUIT "-1"
+22 ;
PROC ; [Procedure] Create report entry in file (703.1)
+1 DO PROC^MDHL7U
+2 QUIT
