- 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 Mar 13, 2025@20:47:22 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
