source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJ078B.m@ 1141

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

initial load of WorldVistAEHR
File size: 5.5 KB
Line 
1PSJ078B ;BIR/JLC - Check for stop date problems ;08-MAY-02 / 10:34 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**78**;16 DEC 97
3 ;
4 ;Reference to ^PS(55 is supported by DBIA# 2191.
5 ;
6XREFS ;
7 N PSJXD,PSJSTP
8 S PSJXD=0 F S PSJXD=$O(^PS(55,"AUDS",PSJXD)) Q:'PSJXD D
9 . S PSJPDFN=0
10 . F S PSJPDFN=$O(^PS(55,"AUDS",PSJXD,PSJPDFN)) Q:'PSJPDFN D
11 .. S PSJORD=0
12 .. F S PSJORD=$O(^PS(55,"AUDS",PSJXD,PSJPDFN,PSJORD)) Q:'PSJORD D
13 ... K XREF S XREF="AUDS" D CHKREF(XREF)
14 S PSJPDFN=0 F S PSJPDFN=$O(^PS(55,PSJPDFN)) Q:'PSJPDFN D
15 . S PSJXD=0
16 . F S PSJXD=$O(^PS(55,PSJPDFN,5,"AUS",PSJXD)) Q:'PSJXD D
17 .. S PSJORD=0
18 .. F S PSJORD=$O(^PS(55,PSJPDFN,5,"AUS",PSJXD,PSJORD)) Q:'PSJORD D
19 ... K XREF S XREF="AUS" D CHKREF(XREF)
20 S PSJPDFN=0 F S PSJPDFN=$O(^PS(55,PSJPDFN)) Q:'PSJPDFN D
21 . S PSJST="" F S PSJST=$O(^PS(55,PSJPDFN,5,"AU",PSJST)) Q:PSJST="" D
22 .. S PSJXD=0
23 .. F S PSJXD=$O(^PS(55,PSJPDFN,5,"AU",PSJST,PSJXD)) Q:'PSJXD D
24 ... S PSJORD=0 F S PSJORD=$O(^PS(55,PSJPDFN,5,"AU",PSJST,PSJXD,PSJORD)) Q:'PSJORD D
25 .... K XREF S XREF="AU" D CHKREF(XREF)
26 S PSJXD=0 F S PSJXD=$O(^PS(55,"AUD",PSJXD)) Q:'PSJXD D
27 . S PSJPDFN=0
28 . S PSJPDFN=$O(^PS(55,"AUD",PSJXD,PSJPDFN)) Q:'PSJPDFN D
29 .. S PSJORD=0
30 .. F S PSJORD=$O(^PS(55,"AUD",PSJXD,PSJPDFN,PSJORD)) Q:'PSJORD D
31 ... K XREF S XREF="AUD" D CHKREF(XREF)
32 S PSJXD=0 F S PSJXD=$O(^PS(55,"AIVS",PSJXD)) Q:'PSJXD D
33 . S PSJPDFN=0
34 . F S PSJPDFN=$O(^PS(55,"AIVS",PSJXD,PSJPDFN)) Q:'PSJPDFN D
35 .. S PSJORD=0
36 .. F S PSJORD=$O(^PS(55,"AIVS",PSJXD,PSJPDFN,PSJORD)) Q:'PSJORD D
37 ... K XREF S XREF="AIVS" D CHKREF(XREF)
38 S PSJPDFN=0 F S PSJPDFN=$O(^PS(55,PSJPDFN)) Q:'PSJPDFN D
39 . S PSJXD=0
40 . F S PSJXD=$O(^PS(55,PSJPDFN,"IV","AIS",PSJXD)) Q:'PSJXD D
41 .. S PSJORD=0
42 .. F S PSJORD=$O(^PS(55,PSJPDFN,"IV","AIS",PSJXD,PSJORD)) Q:'PSJORD D
43 ... K XREF S XREF="AIS" D CHKREF(XREF)
44 S PSJPDFN=0 F S PSJPDFN=$O(^PS(55,PSJPDFN)) Q:'PSJPDFN D
45 . S PSJST=""
46 . F S PSJST=$O(^PS(55,PSJPDFN,"IV","AIT",PSJST)) Q:PSJST="" D
47 .. S PSJXD=0
48 .. F S PSJXD=$O(^PS(55,PSJPDFN,"IV","AIT",PSJST,PSJXD)) Q:'PSJXD D
49 ... S PSJORD=0
50 ... F S PSJORD=$O(^PS(55,PSJPDFN,"IV","AIT",PSJST,PSJXD,PSJORD)) Q:'PSJORD D
51 .... K XREF S XREF="AIT" D CHKREF(XREF)
52 S PSJXD=0 F S PSJXD=$O(^PS(55,"AIV",PSJXD)) Q:'PSJXD D
53 . S PSJPDFN=0
54 . F S PSJPDFN=$O(^PS(55,"AIV",PSJXD,PSJPDFN)) Q:'PSJPDFN D
55 .. S PSJORD=0
56 .. S PSJORD=$O(^PS(55,"AIV",PSJXD,PSJPDFN,PSJORD)) Q:'PSJORD D
57 ... K XREF S XREF="AIV" D CHKREF(XREF)
58 D XCLEAN
59 Q
60 ;
61CHKREF(REF) ;Check cross references
62 ; UD cross refs
63 N PSJST,DATES
64 I REF["AU" D Q
65 . S PSJND0=$G(^PS(55,PSJPDFN,5,PSJORD,0)),PSJST=$P(PSJND0,"^",7)
66 . S PSJND2=$G(^PS(55,PSJPDFN,5,PSJORD,2))
67 . S START=$P(PSJND2,"^",2),STOP=$P(PSJND2,"^",4)
68 . I REF="AUDS" D Q
69 .. I START,(START'=PSJXD) D
70 ... S DATES=START_"^"_STOP_"^"_PSJXD_"^^"_PSJST
71 ... S ^XTMP("PSJ XREF",REF,PSJPDFN,PSJORD,PSJXD)=DATES
72 . I STOP,(STOP'=PSJXD) S DATES=START_"^"_STOP_"^^"_PSJXD_"^"_PSJST D
73 .. S ^XTMP("PSJ XREF",REF,PSJPDFN,PSJORD,PSJXD)=DATES
74 ; IV cross refs
75 Q:REF'["AI"
76 S PSJND0=$G(^PS(55,PSJPDFN,"IV",PSJORD,0))
77 S PSJND2=$G(^PS(55,PSJPDFN,"IV",PSJORD,2))
78 S START=$P(PSJND0,"^",2),STOP=$P(PSJND0,"^",3),PSJST=$P(PSJND0,"^",4)
79 I REF="AIVS" D Q
80 . I START,(START'=PSJXD) S DATES=START_"^"_STOP_"^"_PSJXD_"^^"_PSJST D
81 .. S ^XTMP("PSJ XREF",REF,PSJPDFN,PSJORD,PSJXD)=DATES
82 I STOP,(STOP'=PSJXD) S DATES=START_"^"_STOP_"^^"_PSJXD_"^"_PSJST D
83 . S ^XTMP("PSJ XREF",REF,PSJPDFN,PSJORD,PSJXD)=DATES
84 Q
85 ;
86XCLEAN ;
87 N PSJPDFN,PSJORD,PSJSTP,PSJSTRT,OPSJSTRT,OPSJSTP,DATES
88 S REF="" F S REF=$O(^XTMP("PSJ XREF",REF)) Q:REF="" D
89 . S PSJPDFN=0
90 . F S PSJPDFN=$O(^XTMP("PSJ XREF",REF,PSJPDFN)) Q:'PSJPDFN D
91 .. S PSJORD=0
92 .. F S PSJORD=$O(^XTMP("PSJ XREF",REF,PSJPDFN,PSJORD)) Q:'PSJORD D
93 ... S PSJXD=0
94 ... F S PSJXD=$O(^XTMP("PSJ XREF",REF,PSJPDFN,PSJORD,PSJXD)) Q:'PSJXD D
95 .... S DATES=^(PSJXD),PSJSTRT=$P(DATES,"^"),PSJSTP=$P(DATES,"^",2)
96 .... S OPSJSTRT=$P(DATES,"^",3),OPSJSTP=$P(DATES,"^",4)
97 .... S PSJST=$P(DATES,"^",5)
98 .... D @REF
99 Q
100 ;
101UDSTART ; UD Start Date/Time Xrefs ("AUDS")
102 Q:'PSJSTRT!($L(PSJSTRT)<5)
103 S $P(^PS(55,PSJPDFN,5,PSJORD,2),"^",2)=+PSJSTRT
104AUDS ;
105 S ^PS(55,"AUDS",+PSJSTRT,PSJPDFN,PSJORD)=""
106 Q:'$G(OPSJSTRT)
107 K ^PS(55,"AUDS",OPSJSTRT,PSJPDFN,PSJORD)
108 Q
109UDSTOP ; UD Stop Date/Time Xrefs ("AU","AUS","AUD")
110 Q:'PSJSTP!($L(PSJSTP)<5)
111 S $P(^PS(55,PSJPDFN,5,PSJORD,2),"^",4)=+PSJSTP
112AU ;
113AUS ;
114AUD I PSJST?1.2U S ^PS(55,PSJPDFN,5,"AU",PSJST,+PSJSTP,PSJORD)=""
115 S ^PS(55,PSJPDFN,5,"AUS",+PSJSTP,PSJORD)=""
116 S ^PS(55,"AUD",+PSJSTP,PSJPDFN,PSJORD)=""
117 Q:$G(OPSJSTP)=""
118 I PSJST?1.2U K ^PS(55,PSJPDFN,5,"AU",PSJST,OPSJSTP,PSJORD)
119 K ^PS(55,PSJPDFN,5,"AUS",OPSJSTP,PSJORD)
120 K ^PS(55,"AUD",OPSJSTP,PSJPDFN,PSJORD)
121UDNVDT ;
122 S:$G(PSJNVDT)]"" $P(^PS(55,PSJPDFN,5,PSJORD,4),"^",2)=+$G(PSJNVDT)
123 Q
124IVSTART ; IV Start Date/Time Xrefs ("AIVS")
125 Q:'PSJSTRT!($L(PSJSTP)<5)
126 S $P(^PS(55,PSJPDFN,"IV",PSJORD,0),"^",2)=+PSJSTRT
127AIVS ;
128 S ^PS(55,"AIVS",+PSJSTRT,PSJPDFN,PSJORD)=""
129 Q:$G(OPSJSTRT)=""
130 K ^PS(55,"AIVS",OPSJSTRT,PSJPDFN,PSJORD)
131 Q
132IVSTOP ; IV Stop Date/Time Xrefs ("AIS","AIT","AIV")
133 Q:'PSJSTP!($L(PSJSTP)<5)
134 S $P(^PS(55,PSJPDFN,"IV",PSJORD,0),"^",3)=+PSJSTP
135AIT ;
136AIS ;
137AIV I PSJST?1.2U S ^PS(55,PSJPDFN,"IV","AIT",PSJST,+PSJSTP,PSJORD)=""
138 S ^PS(55,PSJPDFN,"IV","AIS",+PSJSTP,PSJORD)=""
139 S ^PS(55,"AIV",+PSJSTP,PSJPDFN,PSJORD)=""
140 I PSJST?1.2U S ^PS(55,PSJPDFN,"IV","AIT",PSJST,+PSJSTP,PSJORD)=""
141 Q:$G(OPSJSTP)=""
142 I PSJST?1.2U K ^PS(55,PSJPDFN,"IV","AIT",PSJST,OPSJSTP,PSJORD)
143 K ^PS(55,PSJPDFN,"IV","AIS",OPSJSTP,PSJORD)
144 K ^PS(55,"AIV",OPSJSTP,PSJPDFN,PSJORD)
145IVNVDT ;
146 S:$G(PSJNVDT)]"" $P(^PS(55,PSJPDFN,"IV",PSJORD,4),"^",2)=+$G(PSJNVDT)
147 Q
Note: See TracBrowser for help on using the repository browser.