- DVBCHLR ;ALB/JLU-Processes the results from the ORU ;1/28/93
- ;;2.7;AMIE;**9,193**;Apr 10, 1995;Build 84
- ;
- BEG D INIT
- F D @$S(DVBCX="PID"&'$D(HLERR):"PID",DVBCX="OBR"&'$D(HLERR):"OBR",DVBCX="OBX"&'$D(HLERR):"OBX",1:"ACK") Q:DVBCX="QUIT"
- D EXIT
- Q
- ;
- EXIT K %,DA,DFN,DIE,DR,DVBC,HLERR,DVBCNT2,DVBCOBR,DVBCOBX,DVBCOBXV,DVBCPAT,DVBCPDFN,DVBCPID,DVBCRPDT,DVBCSAV,DVBCSSN,DVBCUEX,DVBCUEXT,DVBCUNIV,DVBCURQ,DVBCX,DVBCX1,DVBX,VADM,VAERR,DVBCEXAM,DVBCST,DVBCELCT,DVBCUEX1
- Q
- ;
- INIT ;initializes and checks variables
- S DVBCX="PID",DVBC=1
- I '$D(HLESIG) S HLERR="No Electronic Signature code present, updating cannot be allowed."
- I $S('$D(HLDUZ):1,HLDUZ']"":1,1:0) S HLERR="Not a valid DHCP user number."
- Q
- ;
- PID ;Brake apart the PID section
- K HLERR,DVBCPID,DVBCSSN,DVBCPDFN,DVBCPAT,DFN,VAERR,VADM
- S DVBC=$O(^HL(772,HLDA,"IN",DVBC))
- I 'DVBC S HLERR="Missing PID Segment" Q
- S DVBCPID=^(DVBC,0) ;NAKE FROM ^HL(772,HLDA,IN PID+2
- I $P(DVBCPID,HLFS,1)'="PID" S HLERR="Incorrect PID Segment indicator" Q
- I $P(DVBCPID,HLFS,4)']"" S HLERR="Internal Patient ID Missing" Q
- I $P(DVBCPID,HLFS,6)']"" S HLERR="Patient Name Invalid" Q
- I $P(DVBCPID,HLFS,20)']"" S HLERR="Patient SSN Invalid" Q
- S DVBCSSN=$P(DVBCPID,HLFS,20)
- S DVBCPDFN=+$P(DVBCPID,HLFS,4)
- S DVBCPAT=$$FMNAME^HLFNC($P(DVBCPID,HLFS,6))
- S DFN=DVBCPDFN
- D DEM^VADPT
- I VAERR S HLERR="Incorrect Patient Identifier" Q
- I DVBCSSN'=$P(VADM(2),U,1) S HLERR="Invalid SSN" Q
- S DVBCX="OBR"
- Q
- ;
- OBR ;Parsing the OBR segment.
- K DVBCOBR,DVBCUNIV
- F S DVBC=$O(^HL(772,HLDA,"IN",DVBC)) Q:DVBC="" S DVBCOBR=^(DVBC,0) Q:$P(DVBCOBR,HLFS,1)="OBR"
- I DVBC="" S HLERR="Missing OBR Segment" Q
- I $P(DVBCOBR,HLFS,5)']"" S HLERR="Missing Universal Identifier" Q
- I $P(DVBCOBR,HLFS,21)']"" S HLERR="Missing Exam Type" Q
- I $P(DVBCOBR,HLFS,23)']"" S HLERR="Missing Report Date" Q
- S DVBCUNIV=$P(DVBCOBR,HLFS,5)
- S DVBCUEXT=$P(DVBCOBR,HLFS,21)
- S DVBCRPDT=$$FMDATE^HLFNC($P(DVBCOBR,HLFS,23))
- S DVBCURQ=$P(DVBCUNIV,$E(HLECH),1)
- S DVBCUEX=$P(DVBCUNIV,$E(HLECH),2)
- I '$D(^DVB(396.3,DVBCURQ,0)) S HLERR="Request No longer Exists" Q
- I "PS"'[$P(^(0),U,18) S HLERR="Status of Request will not allow for down loading" Q ;NAKED FROM LINE BEFORE
- I '$D(^DVB(396.4,DVBCUEX,0)) S HLERR="Exam No longer Exists" Q
- S DVBCUEX1=^DVB(396.4,DVBCUEX,0)
- I "RXT"[$P(DVBCUEX1,U,4) S HLERR="Exam status not open, no down loading allow* ed" Q
- D HASH^DVBCHLUT
- I '$D(DVBCELCT) S HLERR="Bad electronic signature code." Q
- I $P(DVBCUEX1,U,4)="C",$P(DVBCUEX1,U,10)'=DVBCELCT S HLERR="Electronic signature codes do not match, no down loading allowed" Q
- S DVBCX="OBX"
- Q
- ;
- OBX ;looping through the OBX segment
- K DVBCSAV
- S DVBCNT2=0,DVBCSAV=DVBC
- I '$$LOCK^DVBCHLUT(DVBCURQ,DVBCUEX) Q
- D DEL
- F S DVBC=$O(^HL(772,HLDA,"IN",DVBC)) S:DVBC="" DVBCX="ACK" Q:DVBC="" S DVBCOBX=^(DVBC,0) D OBX1 Q:DVBCX'="OBX" S DVBCSAV=DVBC
- S DVBC=DVBCSAV
- I 'DVBCNT2 S HLERR="Invalid OBX Segment" D UNLOCK^DVBCHLUT(DVBCURQ,DVBCUEX) Q
- I DVBCNT2 D CLOSE
- D UNLOCK^DVBCHLUT(DVBCURQ,DVBCUEX)
- Q
- ;
- OBX1 ;
- S DVBCOBXV=$P(DVBCOBX,HLFS,1)
- I DVBCOBXV="NTE" Q
- I $S(DVBCOBXV="PID":1,DVBCOBXV="OBR":1,1:0) S DVBCX=DVBCOBXV Q
- I DVBCOBXV'="OBX" S DVBCX="ACK" Q
- S DVBCNT2=DVBCNT2+1
- S ^DVB(396.4,DVBCUEX,"RES",DVBCNT2,0)=$P(DVBCOBX,HLFS,6)
- Q
- ;
- CLOSE ;sets exam fields and quits
- D NOW^%DTC
- S ^DVB(396.4,DVBCUEX,"RES",0)="^^"_DVBCNT2_"^"_DVBCNT2_"^"_%
- S DIE="^DVB(396.4,",DA=DVBCUEX
- S DR=".04///C;.06///^S X=DVBCRPDT;.07///^S X=$P(^VA(200,HLDUZ,0),U,1);.1///^S X=DVBCELCT"
- D ^DIE
- S DVBCEXAM=^DVB(396.4,DVBCUEX,0)
- I $P(DVBCEXAM,U,4)'="C"!($P(DVBCEXAM,U,6)']"")!$P(DVBCEXAM,U,7)']"" S HLERR="Results added but request and exam status not updated." Q
- D COMPL
- Q
- ;
- ACK ;setting up the acknowledgment segment.
- I $D(HLERR) S DVBCX1=HLSDATA(1) K HLSDATA S HLSDATA(1)=DVBCX1
- S HLSDATA(2)="MSA"_HLFS_$S($D(HLERR):"AE",1:"AA")_HLFS_HLMID_HLFS_$S($D(HLERR):HLERR,1:"")
- S DVBCX="QUIT"
- I $D(HLTRANS) D EN1^HLTRANS
- Q
- ;
- COMPL ;This subroutine will search the other exams and set the request's
- ;status to transcribed if able.
- ;This should become a callable subroutine because ^dvbcedit does the same
- ;
- K DVBCOPN
- F DVBC=0:0 S DVBC=$O(^DVB(396.4,"C",DVBCURQ,DVBC)) Q:'DVBC S DVBCST=$P(^DVB(396.4,DVBC,0),U,4) I DVBCST="O"!(DVBCST="T") S DVBCOPN=1 Q
- Q:$D(DVBCOPN)
- S XMDUZ="Kurzweil"
- S XMB="DVBA C 2507 EXAM READY"
- S XMB(1)=DVBCPAT,XMB(2)=DVBCSSN
- S Y=$P(^DVB(396.3,DVBCURQ,0),U,2)
- X ^DD("DD")
- S XMB(3)=Y
- D ^XMB
- K XMDUZ,XMB,Y
- S DIE="^DVB(396.3,",DA=DVBCURQ
- ;AJF;Request Status Conversion
- S DR="11///NOW;17////8"
- D ^DIE
- I $P(^DVB(396.3,DVBCURQ,0),U,12)']""!($P(^(0),U,18)'=8) S HLERR="Results added and exam status updated but request status not updated."
- Q
- ;
- DEL ;to delete the results from an exam if it is being resent.
- I $P(DVBCUEX1,U,10)]"" K ^DVB(396.4,DVBCUEX,"RES")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCHLR 4910 printed Feb 18, 2025@23:10:45 Page 2
- DVBCHLR ;ALB/JLU-Processes the results from the ORU ;1/28/93
- +1 ;;2.7;AMIE;**9,193**;Apr 10, 1995;Build 84
- +2 ;
- BEG DO INIT
- +1 FOR
- DO @$SELECT(DVBCX="PID"&'$DATA(HLERR):"PID",DVBCX="OBR"&'$DATA(HLERR):"OBR",DVBCX="OBX"&'$DATA(HLERR):"OBX",1:"ACK")
- if DVBCX="QUIT"
- QUIT
- +2 DO EXIT
- +3 QUIT
- +4 ;
- EXIT KILL %,DA,DFN,DIE,DR,DVBC,HLERR,DVBCNT2,DVBCOBR,DVBCOBX,DVBCOBXV,DVBCPAT,DVBCPDFN,DVBCPID,DVBCRPDT,DVBCSAV,DVBCSSN,DVBCUEX,DVBCUEXT,DVBCUNIV,DVBCURQ,DVBCX,DVBCX1,DVBX,VADM,VAERR,DVBCEXAM,DVBCST,DVBCELCT,DVBCUEX1
- +1 QUIT
- +2 ;
- INIT ;initializes and checks variables
- +1 SET DVBCX="PID"
- SET DVBC=1
- +2 IF '$DATA(HLESIG)
- SET HLERR="No Electronic Signature code present, updating cannot be allowed."
- +3 IF $SELECT('$DATA(HLDUZ):1,HLDUZ']"":1,1:0)
- SET HLERR="Not a valid DHCP user number."
- +4 QUIT
- +5 ;
- PID ;Brake apart the PID section
- +1 KILL HLERR,DVBCPID,DVBCSSN,DVBCPDFN,DVBCPAT,DFN,VAERR,VADM
- +2 SET DVBC=$ORDER(^HL(772,HLDA,"IN",DVBC))
- +3 IF 'DVBC
- SET HLERR="Missing PID Segment"
- QUIT
- +4 ;NAKE FROM ^HL(772,HLDA,IN PID+2
- SET DVBCPID=^(DVBC,0)
- +5 IF $PIECE(DVBCPID,HLFS,1)'="PID"
- SET HLERR="Incorrect PID Segment indicator"
- QUIT
- +6 IF $PIECE(DVBCPID,HLFS,4)']""
- SET HLERR="Internal Patient ID Missing"
- QUIT
- +7 IF $PIECE(DVBCPID,HLFS,6)']""
- SET HLERR="Patient Name Invalid"
- QUIT
- +8 IF $PIECE(DVBCPID,HLFS,20)']""
- SET HLERR="Patient SSN Invalid"
- QUIT
- +9 SET DVBCSSN=$PIECE(DVBCPID,HLFS,20)
- +10 SET DVBCPDFN=+$PIECE(DVBCPID,HLFS,4)
- +11 SET DVBCPAT=$$FMNAME^HLFNC($PIECE(DVBCPID,HLFS,6))
- +12 SET DFN=DVBCPDFN
- +13 DO DEM^VADPT
- +14 IF VAERR
- SET HLERR="Incorrect Patient Identifier"
- QUIT
- +15 IF DVBCSSN'=$PIECE(VADM(2),U,1)
- SET HLERR="Invalid SSN"
- QUIT
- +16 SET DVBCX="OBR"
- +17 QUIT
- +18 ;
- OBR ;Parsing the OBR segment.
- +1 KILL DVBCOBR,DVBCUNIV
- +2 FOR
- SET DVBC=$ORDER(^HL(772,HLDA,"IN",DVBC))
- if DVBC=""
- QUIT
- SET DVBCOBR=^(DVBC,0)
- if $PIECE(DVBCOBR,HLFS,1)="OBR"
- QUIT
- +3 IF DVBC=""
- SET HLERR="Missing OBR Segment"
- QUIT
- +4 IF $PIECE(DVBCOBR,HLFS,5)']""
- SET HLERR="Missing Universal Identifier"
- QUIT
- +5 IF $PIECE(DVBCOBR,HLFS,21)']""
- SET HLERR="Missing Exam Type"
- QUIT
- +6 IF $PIECE(DVBCOBR,HLFS,23)']""
- SET HLERR="Missing Report Date"
- QUIT
- +7 SET DVBCUNIV=$PIECE(DVBCOBR,HLFS,5)
- +8 SET DVBCUEXT=$PIECE(DVBCOBR,HLFS,21)
- +9 SET DVBCRPDT=$$FMDATE^HLFNC($PIECE(DVBCOBR,HLFS,23))
- +10 SET DVBCURQ=$PIECE(DVBCUNIV,$EXTRACT(HLECH),1)
- +11 SET DVBCUEX=$PIECE(DVBCUNIV,$EXTRACT(HLECH),2)
- +12 IF '$DATA(^DVB(396.3,DVBCURQ,0))
- SET HLERR="Request No longer Exists"
- QUIT
- +13 ;NAKED FROM LINE BEFORE
- IF "PS"'[$PIECE(^(0),U,18)
- SET HLERR="Status of Request will not allow for down loading"
- QUIT
- +14 IF '$DATA(^DVB(396.4,DVBCUEX,0))
- SET HLERR="Exam No longer Exists"
- QUIT
- +15 SET DVBCUEX1=^DVB(396.4,DVBCUEX,0)
- +16 IF "RXT"[$PIECE(DVBCUEX1,U,4)
- SET HLERR="Exam status not open, no down loading allow* ed"
- QUIT
- +17 DO HASH^DVBCHLUT
- +18 IF '$DATA(DVBCELCT)
- SET HLERR="Bad electronic signature code."
- QUIT
- +19 IF $PIECE(DVBCUEX1,U,4)="C"
- IF $PIECE(DVBCUEX1,U,10)'=DVBCELCT
- SET HLERR="Electronic signature codes do not match, no down loading allowed"
- QUIT
- +20 SET DVBCX="OBX"
- +21 QUIT
- +22 ;
- OBX ;looping through the OBX segment
- +1 KILL DVBCSAV
- +2 SET DVBCNT2=0
- SET DVBCSAV=DVBC
- +3 IF '$$LOCK^DVBCHLUT(DVBCURQ,DVBCUEX)
- QUIT
- +4 DO DEL
- +5 FOR
- SET DVBC=$ORDER(^HL(772,HLDA,"IN",DVBC))
- if DVBC=""
- SET DVBCX="ACK"
- if DVBC=""
- QUIT
- SET DVBCOBX=^(DVBC,0)
- DO OBX1
- if DVBCX'="OBX"
- QUIT
- SET DVBCSAV=DVBC
- +6 SET DVBC=DVBCSAV
- +7 IF 'DVBCNT2
- SET HLERR="Invalid OBX Segment"
- DO UNLOCK^DVBCHLUT(DVBCURQ,DVBCUEX)
- QUIT
- +8 IF DVBCNT2
- DO CLOSE
- +9 DO UNLOCK^DVBCHLUT(DVBCURQ,DVBCUEX)
- +10 QUIT
- +11 ;
- OBX1 ;
- +1 SET DVBCOBXV=$PIECE(DVBCOBX,HLFS,1)
- +2 IF DVBCOBXV="NTE"
- QUIT
- +3 IF $SELECT(DVBCOBXV="PID":1,DVBCOBXV="OBR":1,1:0)
- SET DVBCX=DVBCOBXV
- QUIT
- +4 IF DVBCOBXV'="OBX"
- SET DVBCX="ACK"
- QUIT
- +5 SET DVBCNT2=DVBCNT2+1
- +6 SET ^DVB(396.4,DVBCUEX,"RES",DVBCNT2,0)=$PIECE(DVBCOBX,HLFS,6)
- +7 QUIT
- +8 ;
- CLOSE ;sets exam fields and quits
- +1 DO NOW^%DTC
- +2 SET ^DVB(396.4,DVBCUEX,"RES",0)="^^"_DVBCNT2_"^"_DVBCNT2_"^"_%
- +3 SET DIE="^DVB(396.4,"
- SET DA=DVBCUEX
- +4 SET DR=".04///C;.06///^S X=DVBCRPDT;.07///^S X=$P(^VA(200,HLDUZ,0),U,1);.1///^S X=DVBCELCT"
- +5 DO ^DIE
- +6 SET DVBCEXAM=^DVB(396.4,DVBCUEX,0)
- +7 IF $PIECE(DVBCEXAM,U,4)'="C"!($PIECE(DVBCEXAM,U,6)']"")!$PIECE(DVBCEXAM,U,7)']""
- SET HLERR="Results added but request and exam status not updated."
- QUIT
- +8 DO COMPL
- +9 QUIT
- +10 ;
- ACK ;setting up the acknowledgment segment.
- +1 IF $DATA(HLERR)
- SET DVBCX1=HLSDATA(1)
- KILL HLSDATA
- SET HLSDATA(1)=DVBCX1
- +2 SET HLSDATA(2)="MSA"_HLFS_$SELECT($DATA(HLERR):"AE",1:"AA")_HLFS_HLMID_HLFS_$SELECT($DATA(HLERR):HLERR,1:"")
- +3 SET DVBCX="QUIT"
- +4 IF $DATA(HLTRANS)
- DO EN1^HLTRANS
- +5 QUIT
- +6 ;
- COMPL ;This subroutine will search the other exams and set the request's
- +1 ;status to transcribed if able.
- +2 ;This should become a callable subroutine because ^dvbcedit does the same
- +3 ;
- +4 KILL DVBCOPN
- +5 FOR DVBC=0:0
- SET DVBC=$ORDER(^DVB(396.4,"C",DVBCURQ,DVBC))
- if 'DVBC
- QUIT
- SET DVBCST=$PIECE(^DVB(396.4,DVBC,0),U,4)
- IF DVBCST="O"!(DVBCST="T")
- SET DVBCOPN=1
- QUIT
- +6 if $DATA(DVBCOPN)
- QUIT
- +7 SET XMDUZ="Kurzweil"
- +8 SET XMB="DVBA C 2507 EXAM READY"
- +9 SET XMB(1)=DVBCPAT
- SET XMB(2)=DVBCSSN
- +10 SET Y=$PIECE(^DVB(396.3,DVBCURQ,0),U,2)
- +11 XECUTE ^DD("DD")
- +12 SET XMB(3)=Y
- +13 DO ^XMB
- +14 KILL XMDUZ,XMB,Y
- +15 SET DIE="^DVB(396.3,"
- SET DA=DVBCURQ
- +16 ;AJF;Request Status Conversion
- +17 SET DR="11///NOW;17////8"
- +18 DO ^DIE
- +19 IF $PIECE(^DVB(396.3,DVBCURQ,0),U,12)']""!($PIECE(^(0),U,18)'=8)
- SET HLERR="Results added and exam status updated but request status not updated."
- +20 QUIT
- +21 ;
- DEL ;to delete the results from an exam if it is being resent.
- +1 IF $PIECE(DVBCUEX1,U,10)]""
- KILL ^DVB(396.4,DVBCUEX,"RES")
- +2 QUIT