DVBCHLQ ;ALB/JLU-Processing HL7 Query message 1 of 2 routines ;1/28/93
;;2.7;AMIE;;Apr 10, 1995
BEG ;Main entry point for this routine.
D START
D CHKIND:'$D(DVBCERR)
D QRD:'$D(DVBCERR)
D ACK
D EXIT
Q
;
EXIT K DFN,DVBC,DVBC1,DVBCARY,DVBCERR,DVBCEXAM,DVBCEXTY,DVBCNT,DVBCNT1,DVBCPDFN,DVBCQRD,DVBCRDFN,DVBCRQDT,DVBCSRX,DVBCSSN,VADM,VAERR,DVBCSEG
Q
;
START ;This subroutine will check the segment type for QRD
K DVBCERR
S DVBCSEG=4,DVBCNT=0
S DVBCARY=^HL(772,HLDA,"IN",2,0)
S DVBCQRD=DVBCARY ;using naked from start+3
I $P(DVBCQRD,HLFS,1)'="QRD" S DVBCERR="Invalid Segment Type" Q
Q
;
CHKIND ;Checking for the requestor's DUZ
I $S('$D(HLDUZ):1,HLDUZ']"":1,1:0) S DVBCERR="Not a valid DHCP user number."
Q
;
QRD ;This subroutine is to break apart the QRD segment of a query
S DVBCNT1=$P($P(DVBCQRD,HLFS,8),$E(HLECH),1) ;gets the max number to return
S:$P(DVBCQRD,HLFS,11)="PATIENT" DVBCSSN=$P(DVBCQRD,HLFS,9)
DO
.I '$D(DVBCSSN) S DVBCERR="Invalid Patient ID, No SSN" Q ;undefined ssn
.I (DVBCSSN'?9N),(DVBCSSN'?9N1A),(DVBCSSN'?1A4N) S DVBCERR="Invalid Patient ID, Wrong SSN Format" Q ;ssn format
.D SSN
.Q
Q
;
SSN ;Checking the existence of the patient with ssn
S:$E(DVBCSSN)?1L DVBCSSN=$C($A($E(DVBCSSN))-32)_$E(DVBCSSN,2,5) ;lower to uppercase letter
S DVBCSRX=$S(DVBCSSN?1U4N:"BS5",1:"SSN") ;getting correct x-ref
I $L(DVBCSSN)=10 S:$E(DVBCSSN,10,10)?1L DVBCSSN=$E(DVBCSSN,1,9)_$C($A($E(DVBCSSN,10,10))-32) ;lowercase to uppercase
S DVBCPDFN=$O(^DPT(DVBCSRX,DVBCSSN,0))
DO
.I 'DVBCPDFN S DVBCERR="Invalid Patient Identifier" Q
.I $O(^DPT(DVBCSRX,DVBCSSN,DVBCPDFN)) S DVBCERR="Ambiguous Patient identifier" Q
.S DVBCRDFN=$O(^DVB(396.3,"B",DVBCPDFN,0))
.I 'DVBCRDFN S DVBCERR="No 2507 request on file for this Patient" Q
.K VADM,VAERR S DFN=DVBCPDFN D DEM^VADPT I VAERR S DVBCERR="Invalid Patient Identifier" Q
.I VADM(1)']"" S DVBCERR="Invalid Patient identifier" Q
.D CHKREQ
.Q
Q
;
CHKREQ ;Checks for an open exam
N ENTRY1,DVBCEXN,DVBCSTAT
F DVBCEXN=0:0 S DVBCEXN=$O(^DVB(396.4,"APS",DVBCPDFN,DVBCEXN)) Q:'DVBCEXN!(DVBCNT=DVBCNT1) D
.S (DVBCEXAM,DVBCSTAT)=""
.F S DVBCSTAT=$O(^DVB(396.4,"APS",DVBCPDFN,DVBCEXN,DVBCSTAT)) Q:DVBCSTAT="" D
..I DVBCSTAT="O" S DVBCEXAM=$O(^DVB(396.4,"APS",DVBCPDFN,DVBCEXN,DVBCSTAT,DVBCEXAM)) D
...S ENTRY1=$P(^DVB(396.4,DVBCEXAM,0),"^",2)
...I "PS"]$P(^DVB(396.3,ENTRY1,0),"^",18) D SET
I 'DVBCNT S DVBCERR="No Exams or Open Exams on file for this Patient"
Q
;
ACK ;builds new QRD and MSA to send back to requestor
S:'$D(DVBCERR) $P(HLSDATA(1),HLFS,9)="ORF"
I $D(DVBCERR) S DVBC=HLSDATA(1) K HLSDATA S HLSDATA(1)=DVBC
S HLSDATA(2)="MSA"_HLFS_$S($D(DVBCERR):"AE",1:"AA")_HLFS_HLMID_$S($D(DVBCERR):HLFS_DVBCERR,1:"")
S HLSDATA(3)=DVBCQRD
S $P(HLSDATA(3),HLFS,8)=DVBCNT_$E(HLECH)_"RD"
I $D(HLTRANS) D EN1^HLTRANS
Q
;
SET ;calls the subroutines to set PID and OBR
S DVBCRDFN=$P(^DVB(396.4,DVBCEXAM,0),U,2)
S DVBCRQDT=$P(^DVB(396.3,DVBCRDFN,0),U,2)
S DVBCEXTY=$P(^DVB(396.6,DVBCEXN,0),U,1) ;gets exam type
D PID^DVBCHLUT
K DVBCPLCR ; this is an OBR filler for the next line
D OBR^DVBCHLUT
S DVBCNT=DVBCNT+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCHLQ 3187 printed Oct 16, 2024@17:45:11 Page 2
DVBCHLQ ;ALB/JLU-Processing HL7 Query message 1 of 2 routines ;1/28/93
+1 ;;2.7;AMIE;;Apr 10, 1995
BEG ;Main entry point for this routine.
+1 DO START
+2 if '$DATA(DVBCERR)
DO CHKIND
+3 if '$DATA(DVBCERR)
DO QRD
+4 DO ACK
+5 DO EXIT
+6 QUIT
+7 ;
EXIT KILL DFN,DVBC,DVBC1,DVBCARY,DVBCERR,DVBCEXAM,DVBCEXTY,DVBCNT,DVBCNT1,DVBCPDFN,DVBCQRD,DVBCRDFN,DVBCRQDT,DVBCSRX,DVBCSSN,VADM,VAERR,DVBCSEG
+1 QUIT
+2 ;
START ;This subroutine will check the segment type for QRD
+1 KILL DVBCERR
+2 SET DVBCSEG=4
SET DVBCNT=0
+3 SET DVBCARY=^HL(772,HLDA,"IN",2,0)
+4 ;using naked from start+3
SET DVBCQRD=DVBCARY
+5 IF $PIECE(DVBCQRD,HLFS,1)'="QRD"
SET DVBCERR="Invalid Segment Type"
QUIT
+6 QUIT
+7 ;
CHKIND ;Checking for the requestor's DUZ
+1 IF $SELECT('$DATA(HLDUZ):1,HLDUZ']"":1,1:0)
SET DVBCERR="Not a valid DHCP user number."
+2 QUIT
+3 ;
QRD ;This subroutine is to break apart the QRD segment of a query
+1 ;gets the max number to return
SET DVBCNT1=$PIECE($PIECE(DVBCQRD,HLFS,8),$EXTRACT(HLECH),1)
+2 if $PIECE(DVBCQRD,HLFS,11)="PATIENT"
SET DVBCSSN=$PIECE(DVBCQRD,HLFS,9)
+3 Begin DoDot:1
+4 ;undefined ssn
IF '$DATA(DVBCSSN)
SET DVBCERR="Invalid Patient ID, No SSN"
QUIT
+5 ;ssn format
IF (DVBCSSN'?9N)
IF (DVBCSSN'?9N1A)
IF (DVBCSSN'?1A4N)
SET DVBCERR="Invalid Patient ID, Wrong SSN Format"
QUIT
+6 DO SSN
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
SSN ;Checking the existence of the patient with ssn
+1 ;lower to uppercase letter
if $EXTRACT(DVBCSSN)?1L
SET DVBCSSN=$CHAR($ASCII($EXTRACT(DVBCSSN))-32)_$EXTRACT(DVBCSSN,2,5)
+2 ;getting correct x-ref
SET DVBCSRX=$SELECT(DVBCSSN?1U4N:"BS5",1:"SSN")
+3 ;lowercase to uppercase
IF $LENGTH(DVBCSSN)=10
if $EXTRACT(DVBCSSN,10,10)?1L
SET DVBCSSN=$EXTRACT(DVBCSSN,1,9)_$CHAR($ASCII($EXTRACT(DVBCSSN,10,10))-32)
+4 SET DVBCPDFN=$ORDER(^DPT(DVBCSRX,DVBCSSN,0))
+5 Begin DoDot:1
+6 IF 'DVBCPDFN
SET DVBCERR="Invalid Patient Identifier"
QUIT
+7 IF $ORDER(^DPT(DVBCSRX,DVBCSSN,DVBCPDFN))
SET DVBCERR="Ambiguous Patient identifier"
QUIT
+8 SET DVBCRDFN=$ORDER(^DVB(396.3,"B",DVBCPDFN,0))
+9 IF 'DVBCRDFN
SET DVBCERR="No 2507 request on file for this Patient"
QUIT
+10 KILL VADM,VAERR
SET DFN=DVBCPDFN
DO DEM^VADPT
IF VAERR
SET DVBCERR="Invalid Patient Identifier"
QUIT
+11 IF VADM(1)']""
SET DVBCERR="Invalid Patient identifier"
QUIT
+12 DO CHKREQ
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
CHKREQ ;Checks for an open exam
+1 NEW ENTRY1,DVBCEXN,DVBCSTAT
+2 FOR DVBCEXN=0:0
SET DVBCEXN=$ORDER(^DVB(396.4,"APS",DVBCPDFN,DVBCEXN))
if 'DVBCEXN!(DVBCNT=DVBCNT1)
QUIT
Begin DoDot:1
+3 SET (DVBCEXAM,DVBCSTAT)=""
+4 FOR
SET DVBCSTAT=$ORDER(^DVB(396.4,"APS",DVBCPDFN,DVBCEXN,DVBCSTAT))
if DVBCSTAT=""
QUIT
Begin DoDot:2
+5 IF DVBCSTAT="O"
SET DVBCEXAM=$ORDER(^DVB(396.4,"APS",DVBCPDFN,DVBCEXN,DVBCSTAT,DVBCEXAM))
Begin DoDot:3
+6 SET ENTRY1=$PIECE(^DVB(396.4,DVBCEXAM,0),"^",2)
+7 IF "PS"]$PIECE(^DVB(396.3,ENTRY1,0),"^",18)
DO SET
End DoDot:3
End DoDot:2
End DoDot:1
+8 IF 'DVBCNT
SET DVBCERR="No Exams or Open Exams on file for this Patient"
+9 QUIT
+10 ;
ACK ;builds new QRD and MSA to send back to requestor
+1 if '$DATA(DVBCERR)
SET $PIECE(HLSDATA(1),HLFS,9)="ORF"
+2 IF $DATA(DVBCERR)
SET DVBC=HLSDATA(1)
KILL HLSDATA
SET HLSDATA(1)=DVBC
+3 SET HLSDATA(2)="MSA"_HLFS_$SELECT($DATA(DVBCERR):"AE",1:"AA")_HLFS_HLMID_$SELECT($DATA(DVBCERR):HLFS_DVBCERR,1:"")
+4 SET HLSDATA(3)=DVBCQRD
+5 SET $PIECE(HLSDATA(3),HLFS,8)=DVBCNT_$EXTRACT(HLECH)_"RD"
+6 IF $DATA(HLTRANS)
DO EN1^HLTRANS
+7 QUIT
+8 ;
SET ;calls the subroutines to set PID and OBR
+1 SET DVBCRDFN=$PIECE(^DVB(396.4,DVBCEXAM,0),U,2)
+2 SET DVBCRQDT=$PIECE(^DVB(396.3,DVBCRDFN,0),U,2)
+3 ;gets exam type
SET DVBCEXTY=$PIECE(^DVB(396.6,DVBCEXN,0),U,1)
+4 DO PID^DVBCHLUT
+5 ; this is an OBR filler for the next line
KILL DVBCPLCR
+6 DO OBR^DVBCHLUT
+7 SET DVBCNT=DVBCNT+1
+8 QUIT
