source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOLZB.m@ 1005

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

initial load of WorldVistAEHR

File size: 5.8 KB
Line 
1RMPOLZB ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98
2 ;;3.0;PROSTHETICS;**29,55**;Feb 09, 1996
3 ;
4 ; ODJ - patch 55 - 1/29/01 - remove hard code 121 mail code and
5 ; replace with extrinsic (AUG-1097-32118)
6 ;
7 ; Input:
8 ;
9 ; JOB - 0: interactive, 1: job
10 ; RMPOLCD - Letter type code
11 ;
12 ; Output: None
13 ;
14 ; Called by:
15 ; EN03^RMPOLT,EN02^RMPOLY
16 N REC,POS
17 ; if interactive select device
18 I 'JOB D FULL^VALM1 Q:'$$DEV
19 ; if print queued
20 I $D(IO("Q")) D Q:'$$QUEUE^RMPOLET1(ZTDESC,ZTRTN,.ZTSAVE) D HOME^%ZIS,EXIT Q
21 . K ZTSAVE
22 . S ZTDESC="RMPO : Patient Letter Print",ZTRTN="START^RMPOLZB"
23 . S (ZTSAVE("RMPOXITE"),ZTSAVE("JOB"),ZTSAVE("RMPOLCD"),ZTSAVE("RMPOSITE"),ZTSAVE("RMPO("),ZTSAVE("^TMP($J,RMPOXITE,"))=""
24 W !,"Printing...."
25 ;
26START ; Print H.O. correspondence for selected letter type
27 N DATE U IO
28 S Y=DT X ^DD("DD") S DATE=Y
29 D HDRL ; initialise header lines
30 S RMPONAM="" F S RMPONAM=$O(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)) Q:RMPONAM="" D
31 . S RMPOLTR=$P(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,1)
32 . S RMPODFN=$P(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
33 . S REC=^TMP($J,RMPOXITE,"RMPODEMO",RMPODFN) D BODY
34 D EXIT Q
35 ;
36ONE ;print a single patient
37 ;I 'JOB D FULL^VALM1 Q:'$$DEV
38 ;D COMMON("PIKSOM") D ^%ZISC D CLEAN^VALM10,INIT^RMPOLT,RE^VALM4 K DIR,RTN
39 D PIKSOM Q:$$QUIT I Y="" S VALMBCK="R" Q
40 S LFNS=Y I 'JOB D FULL^VALM1 Q:'$$DEV
41 I $D(IO("Q")) D D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 2 D HOME^%ZIS,EXIT Q
42 . K ZTSAVE
43 . S ZTDESC="RMPO : Patient Letter Print",ZTRTN="QUED^RMPOLZB"
44 . S (ZTSAVE("RMPOXITE"),ZTSAVE("JOB"),ZTSAVE("RMPOLCD"))=""
45 . S ZTSAVE("RMPOSITE")="",ZTSAVE("RMPO(")="",ZTSAVE("^TMP($J,RMPOXITE,")="",ZTSAVE("IO")="",ZTSAVE("LFNS")=""
46 W !!,"Printing...."
47 ;
48QUED N DATE S Y=DT X ^DD("DD") S DATE=Y D HDRL
49 U IO F ZI=1:1:$L(LFNS,",")-1 D
50 . S LFN=$P(LFNS,",",ZI) Q:LFN'>0
51 . S RMPONAM="",CNT=0 F S RMPONAM=$O(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)) Q:RMPONAM="" D
52 .. S RMPOLTR=$P(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,1)
53 .. S RMPODFN=$P(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
54 .. S CNT=CNT+1
55 .. S:CNT=LFN ^TMP($J,RMPOXITE,"LTR",RMPONAM)=RMPODFN
56 S RMPONAM="" F S RMPONAM=$O(^TMP($J,RMPOXITE,"LTR",RMPONAM)) Q:RMPONAM="" D SINGLE
57 K LFNS,LFN,ZI,RTN,DIR,RMLET
58 D ^%ZISC D CLEAN^VALM10,INIT^RMPOLT,RE^VALM4
59 S VALMBCK="R" D EXIT Q
60 ;
61SINGLE S RMPOLTR=$P(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,1)
62 S RMPODFN=$P(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
63 S REC=^TMP($J,RMPOXITE,"RMPODEMO",RMPODFN)
64 D BODY Q
65BODY ; Set up array for filing and print letter
66 N I,LN,LNCT,SP,HDR,X,Y,NAME,SURNM,FRSTNM
67 S $P(SP," ",80)=" ",LNCT=0
68 ;
69 ; Print text or blank lines in header
70 S HDR=^TMP($J,RMPOXITE,"HEADER",RMPOLTR)
71 I 'HDR F I=1:1:9 D LINE("")
72 I HDR D PHDR
73 ;
74 D LINE(DATE),LINE("")
75 S NAME=$P(REC,U),SURNM=$P(NAME,",",2),FRSTNM=$P(NAME,",")
76 S LN=$E(FRSTNM_" "_SURNM_SP,1,40)_"In Reply Refer To: "_RMPO("NAME")_"/"_$$ROU^RMPRUTIL(RMPOXITE)
77 D LINE(LN)
78 S LN=$P(REC,U,10),LN=$E(LN_SP,1,40)_"SSN: "_$P(REC,U,2)
79 D LINE(LN)
80 S LN=$P(REC,U,11) I LN]"" S LN=$E(LN_SP,1,40) D LINE(LN)
81 I $P(REC,U,12)]"" D LINE($P(REC,U,12))
82 ;
83 ; City, State, Zip
84 D LINE($P(REC,U,13)_", "_$P(REC,U,14)_" "_$P(REC,U,15))
85 ;I $P(REC,U,11)="",$P(REC,U,12)="" D LINE($E(SP,1,40)_$P(RMPODFN,U))
86 S RMPORX=$P(REC,U,6) S:RMPORX="" RMPORX="Not on file"
87 D LINE($E(SP,1,40)_FRSTNM_" "_SURNM)
88 D LINE($E(SP,1,40)_"Current Home Oxygen Rx#: "_RMPORX)
89 S LN=$E(SP,1,40)_"Rx Expiration Date: "
90 S RMPORXDT=$P(REC,U,4)
91 I RMPORXDT="" S RMPORXDT="n/a"
92 E S Y=RMPORXDT X ^DD("DD") S RMPORXDT=Y
93 D LINE(LN_RMPORXDT),LINE("")
94 D LINE("Dear "_$S($P(REC,U,9)="F":"Ms. ",1:"Mr. ")_SURNM_":")
95 D LINE(""),LINE("")
96 ;
97 ; print letter template
98 S I=0 F S I=$O(^RMPR(665.2,RMPOLTR,1,I)) Q:'I D LINE(^(I,0))
99 ;
100 ; Update Correspondence Tracking
101 ; DO NOT remove patient from list is correspondence update unsuccessful.
102 S X=$$FILE^RMPOLZU(RMPODFN,"^TMP("_$J_","_RMPOXITE_",""LINE"")",RMPOLTR)
103 I +X D Q ; quit if error
104 . W !!!,"<<< Error"_+X_":"_$P(X,";",2)_" Patient #"_RMPODFN_" ! >>>",*7
105 D UPDLTR^RMPOLZA(RMPODFN,"@") ; Clear "letter to be sent" field in RMPR(665
106 ;
107 K ^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)
108 K ^TMP($J,RMPOXITE,"LINE")
109 K ^TMP($J,RMPOXITE,RMPODFN)
110 I RMPOLCD="A" S $P(^RMPR(665,RMPODFN,"RMPOA"),U,9)=DT,$P(^("RMPOA"),U,10)="P"
111 I RMPOLCD="B" S $P(^RMPR(665,RMPODFN,"RMPOA"),U,11)=DT,$P(^("RMPOA"),U,12)="P"
112 I RMPOLCD="C" S $P(^RMPR(665,RMPODFN,"RMPOA"),U,13)=DT,$P(^("RMPOA"),U,14)="P"
113 W @IOF
114 Q
115 ;
116LINE(X) S LNCT=LNCT+1,^TMP($J,RMPOXITE,"LINE",LNCT,0)=" "_X
117 W !,?9,X
118 Q
119 ;
120HDRL ; Define header lines
121 S HEAD(1)="Department of Veterans Affairs",POS(1)=40-($L(HEAD(1))\2)
122 S HEAD(2)=RMPO("NAME"),POS(2)=40-($L(HEAD(2))\2) ;name of VAMC
123 S HEAD(3)=RMPO("ADD"),POS(3)=40-($L(HEAD(3))\2) ;street address of VAMC
124 S HEAD(4)=RMPO("CITY"),POS(4)=40-($L(HEAD(4))\2) ;city,state and zip of VAMC
125 Q
126 ;
127PHDR ; Print header
128 F I=1:1:5 D LINE("")
129 D LINE($E(SP,1,POS(1))_HEAD(1)),LINE($E(SP,1,POS(2))_HEAD(2))
130 D LINE($E(SP,1,POS(3))_HEAD(3)),LINE($E(SP,1,POS(4))_HEAD(4))
131 F I=1:1:4 D LINE("")
132 Q
133 ;
134DEV() ; Get device. Cannot be home device
135 N DEV,POP
136 ;F S DEV=0,%ZIS="Q" D ^%ZIS Q:$G(POP)=1 S DEV=1 Q:IO(0)'=IO W "Cannot Select Home Device"
137DAGAIN S DEV=0,%ZIS="MQ" K IOP D ^%ZIS Q:$G(POP)=1 DEV
138 I IO(0)=IO!(IOST["SLAVE") D ^%ZISC,HOME^%ZIS W "Cannot Select Home or Slave Device" G DAGAIN
139 S DEV=1 Q DEV
140EXIT ;Clean up and quit
141 ; if interactive close printer
142 D:'JOB ^%ZISC
143 ;Kill off variables
144 K %ZIS,Y,ZTSAVE,ZTDESC,ZTRTN,HEAD
145 Q
146QUIT() S QUIT=$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q QUIT
147 Q
148COMMON(PIKRTN) ;
149 D FULL^VALM1
150 S RTN="SINGLE^RMPOLZB"
151 D @PIKRTN Q:$$QUIT I Y="" S VALMBCK="R" Q
152 S LFNS=Y
153 I 'JOB Q:'$$DEV
154 Q
155 ;
156PIKSOM ; ALLOW SELECTION FROM DISPLAYED ENTRIES
157 K DIR S DIR(0)="LO^"_VALMBG_":"_VALMLST D ^DIR
158 Q
Note: See TracBrowser for help on using the repository browser.