source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFHUTL.m@ 1800

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

initial load of WorldVistAEHR

File size: 5.5 KB
RevLine 
[613]1VAFHUTL ;ALB/CM/PHH/EG/GAH UTILITIES ROUTINE ; 10/18/06
2 ;;5.3;Registration;**91,151,568,585,725**;Jun 06, 1996;Build 12
3 ;
4 ;
5LTD(DFN) ;
6 ;This function will find the last time seen at the facility
7 ;
8 ; Input: DFN -- pointer to the patient in file #2
9 ;
10 ; Output: FileMan Date/time ^ I,D,R,A,S ^ HL7 Date/time ^ Variable PTR
11 ;
12 ; I = inpatient, D = discharge, R = Registration, A = Appointment
13 ; S = Stop Code
14 ;
15 ; If Unsuccessful, Output: -1^error message
16 ;
17 N LTD,X,FLG,LAST,VARPTR
18 ;
19 S FLG=""
20 ; - need a patient
21 I '$G(DFN) Q "-1^Missing Parameters for LTD function"
22 ;
23 ; - if current inpatient, set LTD = today and quit
24 I $G(^DPT(DFN,.105)) S LTD=DT,FLG="I" I $D(^DGPM("ATID1",DFN)) S LAST=9999999.9999999-($O(^DGPM("ATID1",DFN,""))) G LTDQ
25 ;
26 ; - get the last discharge date
27 S LTD=+$O(^DGPM("ATID3",DFN,"")) S:LTD FLG="D",LAST=9999999.9999999-LTD,LTD=LAST\1 S:LTD>DT (LAST,LTD)=DT
28 ;
29 ; - get the last registration date and compare to LTD
30 S X=+$O(^DPT(DFN,"DIS",0)) I X S X=9999999-X S:(X\1)>LTD LAST=X,LTD=X\1,FLG="R",VARPTR=DFN_";DPT("
31 ;
32 ; - get the last appointment and compare to LTD
33 N SDDATE,SDARRAY,SDCLIEN,SDSTAT
34 S SDDATE=LTD,SDARRAY("FLDS")=3,SDARRAY(4)=DFN
35 I $$SDAPI^SDAMA301(.SDARRAY)>0 D
36 .S SDCLIEN=0
37 .F S SDCLIEN=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN)) Q:'SDCLIEN!(SDDATE>DT) D
38 ..F S SDDATE=$O(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE)) Q:'SDDATE!(SDDATE>DT) D
39 ...S SDSTAT=$P($P(^TMP($J,"SDAMA301",DFN,SDCLIEN,SDDATE),"^",3),";")
40 ...I SDSTAT="R" D
41 ....S LAST=SDDATE,LTD=SDDATE\1,FLG="A"
42 ....I $D(VARPTR) K VARPTR
43 K ^TMP($J,"SDAMA301")
44 ;
45 ; - get the last standalone after LTD
46 S X=$$GETLAST^SDOE(DFN,LTD_".9999")
47 I X S LAST=+$$SCE^DGSDU(X,1,0),LTD=LAST\1,FLG="S",VARPTR=X_";SCE("
48 ;
49LTDQ I '$D(LAST) Q "-1^No last date"
50 I '$D(VARPTR) S VARPTR=$$VPTR(FLG,DFN,LAST)
51 I +VARPTR<1 Q "-1^No last date"
52 Q LAST_"^"_FLG_"^"_$$HLDATE^HLFNC(LAST,"TS")_"^"_VARPTR
53 ;
54 ;
55VPTR(TYPE,DFN,EDATE) ;
56 ;Gets pointer for inpatient/outpatient event
57 ;
58 I '$D(TYPE)!('$D(DFN))!('$D(EDATE)) Q "-1^Missing Parameters for VPTR function"
59 N PTR,IND
60 I TYPE'="A"&(TYPE'="D")&(TYPE'="I") Q "-1^NOT IN or OUT PATIENT"
61 I TYPE="I"!(TYPE="D") D
62 .;inpatient or discharge
63 .S IND=$O(^DGPM("APID",DFN,"")),PTR=$O(^DGPM("APID",DFN,IND,""))
64 .I $D(^DGPM(PTR)) S PTR="-1^MISSING ENTRY"
65 .I +PTR>0 S PTR=PTR_";DGPM("
66 I TYPE="A" D
67 .;outpatient appointment
68 .I $D(^SCE("ADFN",DFN,LAST)) S PTR=$O(^SCE("ADFN",DFN,LAST,"")) S:('$D(^SCE(+PTR,0))) PTR=DFN_";DPT(" S:($D(^SCE(+PTR,0))) PTR=PTR_";SCE("
69 .I '$D(^SCE("ADFN",DFN,LAST)) S PTR=DFN_";DPT("
70 Q PTR
71 ;
72GETF(SEG) ;NOT USED ANY MORE
73 ;This function will return all of the available fields for the SEG
74 ;segment as found in the HL7 DHCP PARAMETER file, as a string,
75 ;separated by commas
76 ;
77 ;Input: SEG - HL7 Segment
78 ;Output: Successful - string of field numbers seperated by commas
79 ;If unsuccessful, -1^error message will be returned.
80 ;
81 ;NOTE: HL("SAN") must be defined as Sending Application in file 771
82 ;N ENT,FLDS
83 ;I '$D(HLENTRY)!('$D(SEG)) Q "-1^MISSING PARAMETERS"
84 ;do lookup in #771 for HLENTRY
85 ;S DIC="^HL(770,",DIC(0)="MQZ",X=HLENTRY D ^DIC
86 ;I +Y<0 Q "-1^NO ENTRY IN FILE 771"
87 ;S ENT=$P(^HL(770,+Y,0),"^",8) I ENT="" Q "-1^NO ENTRY IN APPLICATION FIELD"
88 ;
89 N ENT,FLDS
90 I $G(HL("SAN"))]"",$G(SEG)]""
91 E Q "-1^MISSING PARAMETERS HL(SAN)!SEG"
92 ;
93 S ENT=$O(^HL(771,"B",HL("SAN"),0))
94 I 'ENT Q "-1^NO ENTRY IN FILE 771"
95 ;
96 S DIC="^HL(771,ENT,""SEG"",",X=SEG,DIC(0)="MQZ" D ^DIC
97 K DIC,X
98 I +Y<0 K Y Q "-1^NO ENTRY IN SUBFILE #771.05"
99 S FLDS=$P(^HL(771,ENT,"SEG",+Y,"F"),"^") K Y
100 Q FLDS
101 ;
102UPDATE(PIVOT,ADATE,APTR,REMOVE) ;
103 ;
104 ;This function will allow the updating of PIVOT number entry, updating
105 ;EVENT DATE/TIME and the VARIABLE POINTER and setting of the DELETED
106 ;field.
107 ;
108 ;Input: PIVOT - Pivot Number
109 ; ADATE - Event Date/Time (new)
110 ; APTR - Variable Pointer (new)
111 ; REMOVE - 1 or null if 1 set DELETED field
112 ;
113 ;Output: 0 if successful
114 ; -1^error message if not successful
115 ;
116 I '$D(PIVOT) Q "-1^MISSING PARAMETERS"
117 I '$D(^VAT(391.71,"D",PIVOT)) Q "-1^NO PIVOT ENTRY"
118 I '$D(REMOVE) S REMOVE=""
119 I APTR?.N1";".A1"(" D
120 .I $P(APTR,";",2)="DPT(" S APTR="P.`"_+APTR
121 .I $P(APTR,";",2)="SCE(" S APTR="O.`"_+APTR
122 .I $P(APTR,";",2)="DGMP(" S APTR="I.`"_+APTR
123 S DA=$O(^VAT(391.71,"D",PIVOT,"")) I DA="" Q "-1^BAD CROSS REFERENCE"
124 S DIE="^VAT(391.71,",DIC(0)="MQZ",DR=""
125 I ADATE'="" S DR=DR_".01///"_ADATE_";"
126 I APTR'="" S DR=DR_".05///"_APTR_";"
127 S DR=DR_".07///"_REMOVE
128 L +^VAT(391.71,DA,0):5
129 I '$T Q "-1^Unable to lock entry in Pivot file"
130 D ^DIE L -^VAT(391.71,DA,0)
131 K DIE,DR,DIC,DA,X,Y
132 Q 0
133 ;
134SEND(VAR1) ;this function will test for the on/off parameter to send ADT messages.
135 ;OUTPUTS 0 will indicate NOT to send
136 ; 1 will indicate TO send
137 ; 0 in second piece will indicate NOT to send HL7 v2.3
138 ; 1 in second piece will indicate to send HL7 v2.3
139 N VAR1
140 S VAR1=$O(^DG(43,0))
141 I +VAR1 S VAR1=$P($G(^DG(43,VAR1,"HL7")),"^",2,3)
142 Q VAR1
143 ;
144HLQ(DATA) ;this function returns the value passed to it or HLQ
145 I $G(DATA)="" Q HLQ
146 Q DATA
147 ;
148NOSEND() ;function TURNS OFF the on/off parameter to send ADT messages.
149 ; used by init to disable all ADT HL7 protocols
150 ;
151 ;OUTPUTS 1 will indicate it was SET NOT to send
152 ; 0 will indicate it failed to SET IT NOT to send
153 ;
154 N VAR1
155 S VAR1=$O(^DG(43,0))
156 I +VAR1 S $P(^DG(43,+VAR1,"HL7"),"^",2,3)="0^0" Q 0
157 Q 1
158 ;
159DPROTO(PNAM) ;returns 0 if protocol disabled field is not null, ie disabled
160 ; returns 1 if protocol is NOT disabled
161 I $G(PNAM)]"",$P($G(^ORD(101,+$O(^ORD(101,"B",PNAM,0)),0)),"^",3)]"" Q 0
162 Q 1
Note: See TracBrowser for help on using the repository browser.