source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOLET0.m@ 868

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

initial load of FOIAVistA 6/30/08 version
File size: 7.0 KB
Line 
1RMPOLET0 ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98
2 ;;3.0;PROSTHETICS;**29,46**;Feb 09, 1996
3 ;
4START ;
5 N LST,TXT,TRXS,LTRX
6 ;
7 Q:'$$SITE
8 S LST=$$LST I 'LST G EXIT
9 D:LST=2 PURGE
10 D LTRCR ; generate letter code to prosthetics letter IEN xref
11 K ^TMP($J)
12 ; build patient list work file from current list (GENOLST) or
13 ; generate new patient letter list work file (GENLST)
14 D GENLST:LST'=1,GENOLST(0):LST=1
15 ;
16 D SELECT^RMPOLETA
17 ;
18 L -^TMP("RMPO","LETTERPRINT")
19 G EXIT
20 Q
21 ;
22SITE() ;find the site if the site is not multidivisional
23 ;
24 ;Initialize, if necessary
25 D HOSITE^RMPOUTL0 ; output RMPO("STA") - station number
26 W @IOF K ^TMP($J)
27 I '$G(RMPOREC) W !!,*7,"You must choose a Home Oxygen Site.",!! Q 0
28 S RMPOXITE=RMPOREC
29 Q 1
30 ;
31LST() ;Check Letters List
32 N LST
33 ;
34 S LST=0
35 I $D(^RMPR(665,"ALTR")) D ; if already a patient list in existance exit
36 . S %=2
37 . W !,"A list of patient letters to be printed already exists",!
38 . W !,"Do you wish to reprint the current list" D YN^DICN
39 . I %=1 S LST=1
40 . E S %=2 W !,"Do you wish to generate a new list which will discard any edits" D YN^DICN S:%=1 LST=2
41 E S LST=3
42 I LST S TXT=$S(LST=1:"work with current",LST=2:"regenerate",1:"generate new") S:'$$LOCK(TXT) LST=0
43 Q LST
44 ;
45LTRCR ; build local array CROSS REFERENCE of H.O. letter Code to Letter
46 ;
47 ; ! assumes a letter code can have many letter templates but one !
48 ; ! template is of a particluar type e.g. a 30,60,90 & 120 Day H.O. !
49 ; ! letters are all of type "B" : prescription pending expiry. !
50 ;
51 ; O/P : LTRX("A",Letter Code,Prosthetics Letter IEN)
52 ; LTRX("B",Prosthetics Letter IEN)=Letter Code
53 ;
54 N LTRIEN,REC
55 ;
56 S LTRIEN=0 F S LTRIEN=$O(^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN)) Q:LTRIEN<1 D
57 . S REC=^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN,0),RMPOLTR=$P(REC,U),RMPOLCD=$P(REC,U,2)
58 . I RMPOLCD'="",(RMPOLTR'="") S LTRX("A",RMPOLCD,RMPOLTR)="",LTRX("B",RMPOLTR)=RMPOLCD
59 Q
60 ;
61GENLST ; generate patient letter list
62 N REC,ADT,IADT
63 ;
64 S Z=""
65 F S Z=$O(^RMPR(665,"AHO",Z)) Q:Z="" D
66 .S RMPODFN=0
67 . F S RMPODFN=$O(^RMPR(665,"AHO",Z,RMPODFN)) Q:RMPODFN="" D
68 .. N TRXS
69 .. ;
70 .. Q:$P(^RMPR(665,RMPODFN,"RMPOA"),U,7)'=RMPOXITE ; ignore patient from another station
71 .. ;Get patient demographic data
72 .. S DFN=RMPODFN K VADM D DEM^VADPT
73 .. ;Do not collect patient if expired
74 .. Q:$G(VADM(6))
75 .. S REC=$G(^RMPR(665,RMPODFN,"RMPOA")) Q:REC="" ; not a H.O. patient
76 .. S ADT=$P(REC,U,2),IADT=$P(REC,U,3) ; get Activation & InActivation DaTes
77 .. Q:ADT="" ; quit if not an active H.O. patient
78 .. D FNDTRX ; build Xref of transactions (TRX) to letter type for this patient
79 .. S RMPORX=$P($G(^RMPR(665,RMPODFN,"RMPOB",0)),U,3) ; get active prescription
80 .. ; check if new patient or inactivation letter required
81 .. Q:$$NACT
82 .. ; get active patient prescription and evaluate letter requirement
83 .. Q:'$D(^RMPR(665,RMPODFN,"RMPOB",0))
84 .. Q:RMPORX<1 ; quit if no active prescription
85 .. D EXPR
86 Q
87 ;
88GENOLST(BTYP) ; Generate work file from current patient letter list
89 N LTRIEN
90 ;
91 S RMPOLTR=0 F S RMPOLTR=$O(^RMPR(665,"ALTR",RMPOLTR)) Q:RMPOLTR="" D
92 . S RMPODFN=0 F S RMPODFN=$O(^RMPR(665,"ALTR",RMPOLTR,RMPODFN)) Q:RMPODFN="" D
93 . . S STA=$P(^RMPR(665,RMPODFN,0),U,2) Q:STA'=RMPO("STA") ; ignore patients from another station
94 . . S REC=$G(^RMPR(665,RMPODFN,"RMPOA")),ADT=$P(REC,U,2),IADT=$P(REC,U,3)
95 . . S RMPORX=$P($G(^RMPR(665,RMPODFN,"RMPOB",0)),U,3)
96 . . S LTRIEN=$O(^RMPR(669.9,RMPOXITE,"RMPOLET","B",RMPOLTR,0))
97 . . S RMPOLCD=$P(^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN,0),U,2)
98 . . D EXTRCT(BTYP) S ^TMP($J,"RMPOLST",RMPOLCD,RMPODFN)=RMPOLTR
99 Q
100 ;
101NACT() ; check if new patient letter or inactivation letter is required
102 N FND,LST,DTE
103 ;
104 F RMPOLCD="A","C" D Q:LST ; Quit if letter placed on list
105 . S (LST,FND)=0,RMPOLTR="",DTE=$S(RMPOLCD="A":ADT,1:IADT)
106 . F S RMPOLTR=$O(LTRX("A",RMPOLCD,RMPOLTR)) Q:RMPOLTR="" D Q:FND Q:LST ; for each VALID H.O. letter of given Letter Code
107 . . I $O(TRXS(RMPOLCD,RMPOLTR,(DTE-1))) S FND=1 Q ; quit if letter printed on or after de/activation
108 . . D EXTRCT(0) S ^TMP($J,"RMPOLST",RMPOLCD,RMPODFN)=RMPOLTR S LST=1 ; add person to list as requiring appropriate letter
109 Q FND
110 ;
111EXPR ; check if prescription is pending expiry
112 N REC,LTR,EXP
113 ;
114 S RMPOLCD="B",REC=^RMPR(665,RMPODFN,"RMPOB",RMPORX,0)
115 S RMPOEXP=$P(REC,U,3) Q:RMPOEXP<DT ; quit if prescription already expired
116 S X1=RMPOEXP,X2=DT D ^%DTC S RMPODAYS=X-1
117 S RMPODAYS=$O(^RMPR(669.9,"ALTDY",RMPODAYS))
118 Q:RMPODAYS="" ;no letter for this expiry pending period (zero to n days)
119 Q:'$D(^RMPR(669.9,"ALTDY",RMPODAYS,RMPOXITE)) ; ignore letters defined for other sites
120 S LTR=$O(^RMPR(669.9,"ALTDY",RMPODAYS,RMPOXITE,0)) ;get FIRST letter assoc. with this expiry period
121 S RMPOLTR=$P(^RMPR(669.9,RMPOXITE,"RMPOLET",LTR,0),U) ; get H.O. letter
122 Q:$D(TRXS(RMPOLCD,RMPOLTR)) ; H.O. letter for this expiry period has been sent
123 D EXTRCT(0) S ^TMP($J,"RMPOLST",RMPOLCD,RMPODFN)=RMPOLTR
124 Q
125 ;
126EXTRCT(BTYP) ;
127 ;
128 ; I/P : Build TYPe - 0=List, 1=Letter
129 ;
130 ; quit if already generated demographic details for a patient
131 Q:$D(^TMP($J,"RMPODEMO",RMPODFN))
132 ;
133 N INAME,INFO
134 ;
135 S INAME="",DFN=RMPODFN
136 K VADM D DEM^VADPT,ADD^VADPT
137 S NAME=VADM(1)_U_RMPODFN
138 ;
139 ; if patient has an active prescription get date entered & expiry date else set dates = NULL
140 I RMPORX'="" S RMPOEXP=$P(^RMPR(665,RMPODFN,"RMPOB",RMPORX,0),U,3),RMPORXDT=$P(^(0),U)
141 E S (RMPOEXP,RMPORXDT)=""
142 ;
143 ; get primary item
144 S INAME="",RMPOITEM=$O(^RMPR(665,"AC","Y",RMPODFN,0))
145 I RMPOITEM'="" D
146 . S RMPOITEM=$P(^RMPR(665,RMPODFN,"RMPOC",RMPOITEM,0),U),RMPOITEM=$P(^RMPR(661,RMPOITEM,0),U)
147 . S INAME=$P(^PRC(441,RMPOITEM,0),U,2)
148 ;
149 ;set the ^TMP($J,"RMPODEMO" global with patient demographics
150 S INFO=VADM(1)_U_$P(VADM(2),U,2)_U_ADT_U_RMPOEXP_U_INAME
151 S:BTYP=1 INFO=INFO_U_RMPORX_U_RMPORXDT_U_DT_U_$P(VADM(5),U)_U_VAPA(1)_U_VAPA(2)_U_VAPA(3)_U_VAPA(4)_U_$P(VAPA(5),U,2)_U_VAPA(6)
152 S ^TMP($J,"RMPODEMO",RMPODFN)=INFO
153 Q
154FNDTRX ; find letter TRX & hold in local array
155 ;
156 ; I/P : NONE
157 ; O/P : TRXS(H.O. Letter Code,Prosthetics Letter,Transaction Printed Date)
158 ;
159 N TRX
160 ;
161 S TRX=0 F S TRX=$O(^RMPR(665.4,"B",RMPODFN,TRX)) Q:TRX="" D
162 .
163 . Q:$P(^RMPR(665.4,TRX,0),U,6)'=RMPO("STA") ; ignore letters from a different station
164 . S RMPOLTR=$P(^RMPR(665.4,TRX,0),U,2) Q:'$D(LTRX("B",RMPOLTR)) ; ignore if not a H.O. letter transaction
165 . S RMPOLCD=LTRX("B",RMPOLTR) ; get H.O. Letter Code given H.O. Letter #
166 . S TRXS(RMPOLCD,RMPOLTR,$P(^RMPR(665.4,TRX,0),U,3))="" ; create local array
167 Q
168 ;
169PURGE ; Purge current patient letter list
170 S RMPOLTR=0 F S RMPOLTR=$O(^RMPR(665,"ALTR",RMPOLTR)) Q:RMPOLTR="" D
171 . S RMPODFN=0 F S RMPODFN=$O(^RMPR(665,"ALTR",RMPOLTR,RMPODFN)) Q:RMPODFN="" D UPDLTR(RMPODFN,"@")
172 Q
173 ;
174LOCK(TXT) ;
175 ; lock virtual list record
176 L +^TMP("RMPO","LETTERPRINT"):0 I '$T W !,"Cannot "_TXT_" list as list edit or printing is in progress" Q 0
177 Q 1
178 ;
179UPDLTR(DA,VAL) ; Update 'Letter to be sent' in Prosthetics Patient File
180 ;
181 ; I/P :
182 ; VAL - value to be inserted into field
183 ;
184 S DR="19.13///"_VAL,DIE="^RMPR(665," D ^DIE
185 Q
186 ;
187EXIT G EXIT^RMPOLETA
188
Note: See TracBrowser for help on using the repository browser.