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 Apr 09, 2024@20:46:31 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
