source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOLZ.m@ 1040

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

initial load of FOIAVistA 6/30/08 version
File size: 7.6 KB
Line 
1RMPOLZ ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98
2 ;;3.0;PROSTHETICS;**29,44,46,55**;Feb 09, 1996
3 ;
4 ; ODJ - patch 55 - Ensure we only include prescriptions which are
5 ; due to expire after the number of days set up
6 ; in site params. cf nois UNY-1000-11685
7 ;
8FORGD ; Foreground processing of list
9 N JOB,TRXS,LTRX,SITE,LST
10 K ^TMP($J)
11 S JOB=0 ; foreground flag set
12 ; get site
13 Q:'$$SITE^RMPOLZA("")
14 ; get lock on ^TMP("RMPO",$J,RMPOXITE,"LETTERPRINT")
15 Q:'$$LOCK^RMPOLZA
16 ; get list parameters
17 D LST^RMPOLZC I 'LST K ^TMP("VALM VIDEO",$J) Q
18 I (LST=1),(RL=2) D PURGE^RMPOLZC
19 D GNLST
20 ; Listman control module
21 N QT,LSTN
22 S QT=0 F D Q:QT
23 . S RMPOLCD="" ; clear letter type code
24 . ; call "RMPO Letter Type" list to select letter type
25 . D EN^RMPOLY
26 . I RMPOLCD="" S QT=1 Q ; quit if no letter type is selected
27 . Q:$G(QT)=1
28 . S ^TMP($J,RMPOXITE,"EXIT")=0 ; clear exit to menu flag
29 . ; call "RMPO Letter" list to manage list and print letters
30 . ;D EN^RMPOLT
31 . S QT=^TMP($J,RMPOXITE,"EXIT") ; quit to menu if user requests exit
32 L -^TMP("RMPO",$J,RMPOXITE,"LETTERPRINT") D EXIT
33 Q
34 ;
35BCKGD ; Background processing of list
36 N JOB,TRXS,LTRX,SITE
37 S JOB=1 ; background flag set
38 S RMPOXITE=0 F S RMPOXITE=$O(^RMPR(669.9,RMPOXITE)) Q:RMPOXITE<1 D
39 . Q:'$$SITE^RMPOLZA(RMPOXITE)
40 . Q:'$$LOCK^RMPOLZA
41 . ; generate list & print letters then clear work file
42 . D LST^RMPOLZC D GNLST S RMPOLCD=""
43 . F S RMPOLCD=$O(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD)) Q:RMPOLCD="" D ^RMPOLZB
44 . K ^TMP($J,RMPOXITE)
45 D EXIT
46 Q
47 ;
48EXIT ;
49 K ^TMP($J),DTOUT,DUOUT,DIRUT,DIROUT,LTRX,TRXS
50 K ANS,DIC,X1,X2,Y,ZTSAVE,POP,X,DFN,VADM,VAPA,%,ANSW,%ZIS
51 Q
52 ;
53GNLST ; generate new or recreate original list
54 ; Input: None
55 ; Output:
56 ; ^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)=RMPOLTR^RMPODFN^RMPO
57 D LTRCR^RMPOLZC() ; generate letter code to prosthetics letter IEN xref
58 ; build patient list work file from current list (GENOLST) or
59 ; generate new patient letter list work file (GENLST)
60 I (LST=1),(RL=2) D NEWLST
61 I (LST=2),(RL=2) D ORGLST
62 I (LST=1),(RL=0) D ORGLST
63 Q
64 ;
65NEWLST ; generate NEW patient letter list
66 N RECA,RECB,ADT,IADT W !,"Generating a new list..."
67 I $G(LST) D
68 .K ^RMPR(669.9,RMPOXITE,"RMPOXBAT1"),^RMPR(669.9,RMPOXITE,"RMPOXBAT2")
69 .K ^RMPR(669.9,RMPOXITE,"RMPOXBAT3")
70 .S ^RMPR(669.9,RMPOXITE,"RMPOXBAT1",0)="^669.9002P^^^"
71 .S ^RMPR(669.9,RMPOXITE,"RMPOXBAT2",0)="^669.972P^^^"
72 .S ^RMPR(669.9,RMPOXITE,"RMPOXBAT3",0)="^669.974P^^^"
73 S ADT="" F S ADT=$O(^RMPR(665,"AHO",ADT)) Q:ADT="" D
74 . S RMPODFN=0 F S RMPODFN=$O(^RMPR(665,"AHO",ADT,RMPODFN)) Q:RMPODFN<1 D
75 . . Q:$P(^RMPR(665,RMPODFN,0),U,2)'=RMPO("STA") ; ignore patient from another station
76 . . ;Get patient demographic data
77 . . S DFN=RMPODFN K VADM D DEM^VADPT Q:$G(VADM(6))
78 . . ;Do not collect patient if expired
79 . . S RECA=$G(^RMPR(665,RMPODFN,"RMPOA")),IADT=$P(RECA,U,3) Q:$G(IADT)
80 . . D FNDTRX ; build Xref of transactions (TRX) to letter type
81 . . ; get active patient prescription and evaluate letter requirement
82 . . S RMPORX=$$RXAC^RMPOLZC(RMPODFN)
83 . . Q:'RMPORX
84 . . S RECB=$G(^RMPR(665,RMPODFN,"RMPOB",RMPORX,0))
85 . . S RMDEXP=$P(RECB,U,3),RMDACT=$P(RECB,U,1)
86 . . I $G(LST) D CHECKA
87 . . I '$G(LST) D CHECK1
88 Q
89 ;
90ORGLST ; Generate work file using ORIGINAL patient letter list
91 N LTRIEN,STA W !,"Generating an original list..."
92 F RI="RMPOXBAT1","RMPOXBAT2","RMPOXBAT3" S RMPO=0 F S RMPO=$O(^RMPR(669.9,RMPOXITE,RI,RMPO)) Q:RMPO'>0 D
93 . ;I JOB,'$D(LTRX("B",RMPOLTR)) Q
94 . S RMPODFN=$G(^RMPR(669.9,RMPOXITE,RI,RMPO,0))
95 . S RECA=$G(^RMPR(665,RMPODFN,"RMPOA")),ADT=$P(RECA,U,2),IADT=$P(RECA,U,3)
96 . Q:$G(IADT)
97 . S RMPOLCD=$S(RI="RMPOXBAT1":"A",RI="RMPOXBAT2":"B",RI="RMPOXBAT3":"C",1:"") Q:RMPOLCD=""
98 . S RMPOLTR=$G(LTRX("C",RMPOLCD)) Q:'$G(RMPOLTR)
99 . S STA=$P(^RMPR(665,RMPODFN,0),U,2) Q:STA'=RMPO("STA") ; ignore patients from another station
100 . D PRTCHK
101 . I '$$INCLUDE(RMPODFN,RMPOLCD,.LTRX,RMDPRT,RMFPRT,.RMPORX,.RMDACT) Q ;(patch 55)
102 . S LTRIEN=$O(^RMPR(669.9,RMPOXITE,"RMPOLET","B",RMPOLTR,0))
103 . Q:'$D(^DPT(RMPODFN,0))
104 . S:$D(^DPT(RMPODFN,0)) RMPONAM=$E($P(^DPT(RMPODFN,0),U,1),1,15)
105 . D EXTRCT^RMPOLZA S ^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)=RMPOLTR_"^"_RMPODFN_"^"_RMPO
106 Q
107 ;
108FNDTRX ; find letter TRX & hold in local array
109 ; output: ^TMP($J,DFN,H.O. Letter Code,Prosthetics Letter,Transaction Printed Date)
110 N TRX S TRX=0 F S TRX=$O(^RMPR(665.4,"B",RMPODFN,TRX)) Q:TRX="" D
111 . Q:$P(^RMPR(665.4,TRX,0),U,6)'=RMPO("STA") ; ignore letters from a different station
112 . S RMPOLTR=$P(^RMPR(665.4,TRX,0),U,2) Q:'$D(LTRX("B",RMPOLTR)) ; ignore if not a valid H.O. letter transaction
113 . S RMPOLCD=LTRX("B",RMPOLTR) ; get H.O. Letter Code given H.O. Letter #
114 . S ^TMP($J,RMPODFN,RMPOLCD,RMPOLTR,$P(^RMPR(665.4,TRX,0),U,3))="" ; create local array
115 Q
116 ;
117 ; calc. if any patient prescription should get letter (patch 55)
118INCLUDE(RMPODFN,RMPOLCD,LTRX,RMDPRT,RMFPRT,RMPORX,RMDACT) ;
119 N RMPRINCL,RECB,RMDEXP
120 S RMPRINCL=0
121 S RMPORX=0
122 F S RMPORX=$O(^RMPR(665,RMPODFN,"RMPOB",RMPORX)) Q:'+RMPORX D Q:RMPRINCL
123 . S RECB=$G(^RMPR(665,RMPODFN,"RMPOB",RMPORX,0))
124 . S RMDEXP=+$P(RECB,U,3) ;prescription expiry date
125 . Q:'RMDEXP
126 . S RMDACT=$P(RECB,U,1)
127 . Q:RMDEXP>LTRX("D",RMPOLCD) ;expiry after include period
128 . Q:RMDEXP<DT ;expiry before todays date
129 . I $G(RMFPRT)'="",(RMDPRT>RMDACT) Q
130 . S RMPRINCL=1
131 . Q
132 Q RMPRINCL
133 ;
134CHECKA ; check if patient needs all types of letter.
135 F RMPOLCD="A","B","C" D
136 . S (RMDTE,RMPOLTR)=0,RMPOLTR=$O(LTRX("A",RMPOLCD,RMPOLTR)) Q:'$G(RMPOLTR)
137 . S RMDTE=$O(^TMP($J,RMPODFN,RMPOLCD,RMPOLTR,0))
138 . I RMPOLCD="B",$D(^RMPR(669.9,RMPOXITE,"RMPOXBAT1","B",RMPODFN)) Q
139 . I RMPOLCD="C"&($D(^RMPR(669.9,RMPOXITE,"RMPOXBAT2","B",RMPODFN))!$D(^RMPR(669.9,RMPOXITE,"RMPOXBAT1","B",RMPODFN))) Q
140 . D PRTCHK
141 . I '$$INCLUDE(RMPODFN,RMPOLCD,.LTRX,RMDPRT,RMFPRT,.RMPORX,.RMDACT) Q ;(patch 55)
142 . I RMDPIEC="",RMFPIEC="" Q
143 . Q:RMDTE>RMDACT Q:'$D(^DPT(RMPODFN,0))
144 . S:$D(^DPT(RMPODFN,0)) RMPONAM=$E($P(^DPT(RMPODFN,0),U,1),1,15)
145 . S RMCOD=$S(RMPOLCD="A":"RMPOXBAT1",RMPOLCD="B":"RMPOXBAT2",RMPOLCD="C":"RMPOXBAT3",1:"")
146 . Q:$D(^RMPR(669.9,RMPOXITE,RMCOD,"B",RMPODFN))
147 . K DD,DO S DA(1)=RMPOXITE,DIC="^RMPR(669.9,"_RMPOXITE_","_""""_RMCOD_""""_","
148 . S DIC(0)="L",X=RMPODFN,DLAYGO=669.9 D FILE^DICN Q:'$D(DA) S RMPO=DA K DIC,DA,X
149 . D EXTRCT^RMPOLZA S ^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)=RMPOLTR_"^"_RMPODFN_"^"_RMPO
150 Q
151 ;
152CHECK1 ; check if patient needs a letter (only one type of letter).
153 S (RMDTE,LST)=0,RMPOLTR=""
154 S RMPOLTR=$O(LTRX("A",RMPOLCD,RMPOLTR)) Q:RMPOLTR=""
155 S RMDTE=$O(^TMP($J,RMPODFN,RMPOLCD,RMPOLTR,0))
156 I ((RMPOLCD="B")&$D(^RMPR(669.9,RMPOXITE,"RMPOXBAT2","B",RMPODFN)))!($P(^RMPR(665,RMPODFN,"RMPOA"),U,9)>RMDACT) Q
157 I ((RMPOLCD="C")&$D(^RMPR(669.9,RMPOXITE,"RMPOXBAT3","B",RMPODFN)))!($P(^RMPR(665,RMPODFN,"RMPOA"),U,11)>RMDACT) Q
158 D PRTCHK
159 I '$$INCLUDE(RMPODFN,RMPOLCD,.LTRX,RMDPRT,RMFPRT,.RMPORX,.RMDACT) Q ;(patch 55)
160 I RMDPIEC="",RMFPIEC="" Q
161 Q:RMDTE>RMDACT
162 Q:'$D(^DPT(RMPODFN,0)) S:$D(^DPT(RMPODFN,0)) RMPONAM=$E($P(^DPT(RMPODFN,0),U,1),1,15)
163 S RMCOD=$S(RMPOLCD="A":"RMPOXBAT1",RMPOLCD="B":"RMPOXBAT2",RMPOLCD="C":"RMPOXBAT3",1:"")
164 Q:$D(^RMPR(669.9,RMPOXITE,RMCOD,"B",RMPODFN))
165 K DD,DO S DA(1)=RMPOXITE,DIC="^RMPR(669.9,"_RMPOXITE_","_""""_RMCOD_""""_","
166 S DIC(0)="L",X=RMPODFN,DLAYGO=669.9 D FILE^DICN Q:'$D(DA) S RMPO=DA K DIC,DA,X
167 D EXTRCT^RMPOLZA S ^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)=RMPOLTR_"^"_RMPODFN_"^"_RMPO
168 Q
169PRTCHK S (RMFPRT,RMDPRT,RMFPIEC,RMDPIEC)=""
170 I RMPOLCD="B",$P(RECA,U,10)="" Q
171 I RMPOLCD="C",$P(RECA,U,12)="" Q
172 S RMDPIEC=$S(RMPOLCD="A":9,RMPOLCD="B":11,RMPOLCD="C":13,1:"")
173 S RMFPIEC=$S(RMPOLCD="A":10,RMPOLCD="B":12,RMPOLCD="C":14,1:"")
174 S RMFPRT=$P(RECA,U,RMFPIEC),RMDPRT=$P(RECA,U,RMDPIEC)
175 Q
Note: See TracBrowser for help on using the repository browser.