source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCHLQ.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1DVBCHLQ ;ALB/JLU-Processing HL7 Query message 1 of 2 routines ;1/28/93
2 ;;2.7;AMIE;;Apr 10, 1995
3BEG ;Main entry point for this routine.
4 D START
5 D CHKIND:'$D(DVBCERR)
6 D QRD:'$D(DVBCERR)
7 D ACK
8 D EXIT
9 Q
10 ;
11EXIT K DFN,DVBC,DVBC1,DVBCARY,DVBCERR,DVBCEXAM,DVBCEXTY,DVBCNT,DVBCNT1,DVBCPDFN,DVBCQRD,DVBCRDFN,DVBCRQDT,DVBCSRX,DVBCSSN,VADM,VAERR,DVBCSEG
12 Q
13 ;
14START ;This subroutine will check the segment type for QRD
15 K DVBCERR
16 S DVBCSEG=4,DVBCNT=0
17 S DVBCARY=^HL(772,HLDA,"IN",2,0)
18 S DVBCQRD=DVBCARY ;using naked from start+3
19 I $P(DVBCQRD,HLFS,1)'="QRD" S DVBCERR="Invalid Segment Type" Q
20 Q
21 ;
22CHKIND ;Checking for the requestor's DUZ
23 I $S('$D(HLDUZ):1,HLDUZ']"":1,1:0) S DVBCERR="Not a valid DHCP user number."
24 Q
25 ;
26QRD ;This subroutine is to break apart the QRD segment of a query
27 S DVBCNT1=$P($P(DVBCQRD,HLFS,8),$E(HLECH),1) ;gets the max number to return
28 S:$P(DVBCQRD,HLFS,11)="PATIENT" DVBCSSN=$P(DVBCQRD,HLFS,9)
29 DO
30 .I '$D(DVBCSSN) S DVBCERR="Invalid Patient ID, No SSN" Q ;undefined ssn
31 .I (DVBCSSN'?9N),(DVBCSSN'?9N1A),(DVBCSSN'?1A4N) S DVBCERR="Invalid Patient ID, Wrong SSN Format" Q ;ssn format
32 .D SSN
33 .Q
34 Q
35 ;
36SSN ;Checking the existence of the patient with ssn
37 S:$E(DVBCSSN)?1L DVBCSSN=$C($A($E(DVBCSSN))-32)_$E(DVBCSSN,2,5) ;lower to uppercase letter
38 S DVBCSRX=$S(DVBCSSN?1U4N:"BS5",1:"SSN") ;getting correct x-ref
39 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
40 S DVBCPDFN=$O(^DPT(DVBCSRX,DVBCSSN,0))
41 DO
42 .I 'DVBCPDFN S DVBCERR="Invalid Patient Identifier" Q
43 .I $O(^DPT(DVBCSRX,DVBCSSN,DVBCPDFN)) S DVBCERR="Ambiguous Patient identifier" Q
44 .S DVBCRDFN=$O(^DVB(396.3,"B",DVBCPDFN,0))
45 .I 'DVBCRDFN S DVBCERR="No 2507 request on file for this Patient" Q
46 .K VADM,VAERR S DFN=DVBCPDFN D DEM^VADPT I VAERR S DVBCERR="Invalid Patient Identifier" Q
47 .I VADM(1)']"" S DVBCERR="Invalid Patient identifier" Q
48 .D CHKREQ
49 .Q
50 Q
51 ;
52CHKREQ ;Checks for an open exam
53 N ENTRY1,DVBCEXN,DVBCSTAT
54 F DVBCEXN=0:0 S DVBCEXN=$O(^DVB(396.4,"APS",DVBCPDFN,DVBCEXN)) Q:'DVBCEXN!(DVBCNT=DVBCNT1) D
55 .S (DVBCEXAM,DVBCSTAT)=""
56 .F S DVBCSTAT=$O(^DVB(396.4,"APS",DVBCPDFN,DVBCEXN,DVBCSTAT)) Q:DVBCSTAT="" D
57 ..I DVBCSTAT="O" S DVBCEXAM=$O(^DVB(396.4,"APS",DVBCPDFN,DVBCEXN,DVBCSTAT,DVBCEXAM)) D
58 ...S ENTRY1=$P(^DVB(396.4,DVBCEXAM,0),"^",2)
59 ...I "PS"]$P(^DVB(396.3,ENTRY1,0),"^",18) D SET
60 I 'DVBCNT S DVBCERR="No Exams or Open Exams on file for this Patient"
61 Q
62 ;
63ACK ;builds new QRD and MSA to send back to requestor
64 S:'$D(DVBCERR) $P(HLSDATA(1),HLFS,9)="ORF"
65 I $D(DVBCERR) S DVBC=HLSDATA(1) K HLSDATA S HLSDATA(1)=DVBC
66 S HLSDATA(2)="MSA"_HLFS_$S($D(DVBCERR):"AE",1:"AA")_HLFS_HLMID_$S($D(DVBCERR):HLFS_DVBCERR,1:"")
67 S HLSDATA(3)=DVBCQRD
68 S $P(HLSDATA(3),HLFS,8)=DVBCNT_$E(HLECH)_"RD"
69 I $D(HLTRANS) D EN1^HLTRANS
70 Q
71 ;
72SET ;calls the subroutines to set PID and OBR
73 S DVBCRDFN=$P(^DVB(396.4,DVBCEXAM,0),U,2)
74 S DVBCRQDT=$P(^DVB(396.3,DVBCRDFN,0),U,2)
75 S DVBCEXTY=$P(^DVB(396.6,DVBCEXN,0),U,1) ;gets exam type
76 D PID^DVBCHLUT
77 K DVBCPLCR ; this is an OBR filler for the next line
78 D OBR^DVBCHLUT
79 S DVBCNT=DVBCNT+1
80 Q
Note: See TracBrowser for help on using the repository browser.