source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJ0742.m@ 1250

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

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