source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOTALK2.m@ 1765

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

initial load of FOIAVistA 6/30/08 version

File size: 7.5 KB
Line 
1PSOTALK2 ;BIR/EJW - SCRIPTALK ENROLLMENT FUNCTIONS ;3-28-02
2 ;;7.0;OUTPATIENT PHARMACY;**135,182**;DEC 1997
3 ;External reference ^PS(55 supported by DBIA 2228
4 ;External reference ^TMP("TIUP", ^TIUPNAPI, ^TIU(8925.1 supported by DBIA 1911
5ENROLL ;
6 N PSOSTEN,PSOIND,PSOLAST,DFN
7 S PSOIND=""
8 I '$G(PSOFIRST) D INSTR S PSOFIRST=1
9 W !
10 K DIC W ! S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: " D ^DIC K DIC I Y<1!($D(DUOUT))!($D(DTOUT)) D CLEAN Q
11 S PSOPT=+Y
12 S DFN=PSOPT D DEM^VADPT I +$G(VADM(6)) W !,"Patient is deceased",! G ENROLL
13 I '$D(^PS(55,PSOPT)) D
14 .S DIC="^PS(55,",DLAYGO=55
15 .K DD,DO S DIC(0)="L",(DINUM,X)=PSOPT D FILE^DICN D:Y<1 K DIC,DA,DR,DD,DO
16 ..S $P(^PS(55,PSOPT,0),"^")=PSOPT K DIK S DA=PSOPT,DIK="^PS(55,",DIK(1)=.01 D EN^DIK K DIK
17 S PSOSTEN=$G(^PS(55,"ASTALK",PSOPT))
18 S DIR(0)="Y",DIR("A")="SCRIPTALK PATIENT" S DIR("B")=$S(PSOSTEN:"Y",1:"N") D ^DIR K DIR
19 S PSOSTEN=Y
20 I PSOSTEN D MAIL,GETIND
21 D SET55
22 D NOTE(PSOPT)
23 K PSOIND,PSOPT,PSOSTEN,PSOLAST,X,Y
24 G ENROLL
25 ;
26SET55 ; SET MULTIPLE FOR SCRIPTALK ENROLLMENT AUDIT
27 N PSODA,PSOERR,PSOIEN,PSOSTDT
28 I PSOPT="" Q
29 S PSOSTDT=$$NOW^XLFDT
30 S PSODA(55.0108,"+1,"_PSOPT_",",.01)=PSOSTDT
31 S PSODA(55.0108,"+1,"_PSOPT_",",1)=PSOSTEN
32 S PSODA(55.0108,"+1,"_PSOPT_",",2)=PSOIND
33 S PSODA(55.0108,"+1,"_PSOPT_",",3)=$G(DUZ)
34 D UPDATE^DIE("","PSODA","PSOIEN","PSOERR")
35 Q
36 ;
37GETIND ; GET INDICATION FOR ENROLLMENT
38 S PSOLAST=$P($G(^PS(55,PSOPT,"SCTALK",0)),"^",4) I PSOLAST'="" S PSOIND=$P($G(^PS(55,PSOPT,"SCTALK",PSOLAST,0)),"^",3) ; IF PRIOR ANSWER WAS 'Y' - GET PRIOR INDICATION
39 S DIR(0)="S^B:BLIND VETERAN;L:LOW VISION",DIR("A")="INDICATION" S DIR("B")=PSOIND D ^DIR K DIR
40 S PSOIND=$G(Y)
41 Q
42 ;
43INSTR ;
44 W @IOF
45 I $O(^TIU(8925.1,"B","SCRIPTALK ENROLLMENT",0))="" Q
46 W !
47 W !?3,"At the conclusion of this enrollment option, you will be given"
48 W !?3,"the opportunity to sign a progress note recording the enrollment"
49 W !?3,"of new ScripTalk patients. If you modify the record of a patient"
50 W !?3,"that was previously enrolled, and they remain enrolled, you may"
51 W !?3,"wish to either delete or edit the text of the generated note."
52 W !!
53 K PSOSQ,PSOTT,PSOSTP
54 Q
55 ;
56NOTE(PSOPT) ;CREATE A PROGRESS NOTE FOR PATIENT 'PSOPT' ABOUT ENROLLMENT
57 Q:'+$G(^PS(55,"ASTALK",PSOPT)) ; IF THIS PTS ENROLLMENT ISN'T ACTIVE
58 S PSOTITL=$O(^TIU(8925.1,"B","SCRIPTALK ENROLLMENT",0))
59 Q:'+PSOTITL ;IF NO TITLE ON SYSTEM
60 S PSOPTNM=$P($G(^DPT(PSOPT,0)),U,1)
61 S PSOLINE=1
62 S ^TMP("TIUP",$J,PSOLINE,0)=PSOPTNM_" was enrolled in ScripTalk today, and is now eligible to receive"
63 S PSOLINE=PSOLINE+1
64 S ^TMP("TIUP",$J,PSOLINE,0)="prescriptions with encoded speech-capable labels."
65 S ^TMP("TIUP",$J,0)=U_U_PSOLINE_PSOLINE_U_DT_U
66INSTALL K TIUDA
67 D NEW^TIUPNAPI(.TIUDA,PSOPT,DUZ,$$NOW^XLFDT,PSOTITL)
68 Q
69 ;
70CLEAN K PSOLINE,PSOPTNM,PSOTITL,PSOSTP,PSOPT,PSOFIRST
71 K ^TMP("TIUP",$J)
72 Q
73 ;
74AUDREP ;
75 K DIC W ! S DIC="^DPT(",DIC(0)="QEAM",DIC("A")="Select PATIENT: " D ^DIC K DIC I Y<1!($D(DUOUT))!($D(DTOUT)) Q
76 S PSOPT=+Y
77 S ZTSAVE("*")=""
78 W !!,"You may queue the report to print, if you wish.",!
79 K %ZIS,POP,IOP S %ZIS="QM" D ^%ZIS I $G(POP) W !!,"Nothing queued to print.",! G DONE
80 I $D(IO("Q")) S ZTRTN="AUDRQ^PSOTALK2",ZTDESC="Report of ScripTalk Enrollment",ZTSAVE("*")="" D ^%ZTLOAD K %ZSI W !,"Report queued to print.",! G DONE
81AUDRQ ;
82 U IO
83 S PSOOUT=0,PSODV=$S($E(IOST)="C":"C",1:"P")
84 S PSOPGCT=1
85 D TITLEA I PSOOUT G DONE
86 S PSOAUD=0 F S PSOAUD=$O(^PS(55,PSOPT,"SCTALK",PSOAUD)) Q:PSOAUD="" D I PSOOUT Q
87 .S PSONODE=$G(^PS(55,PSOPT,"SCTALK",PSOAUD,0))
88 .S PSOSTAT=$P(PSONODE,"^",2)
89 .S PSOTIME=$$FMTE^XLFDT($P(PSONODE,U,1)),PSOTIME=$P(PSOTIME,"@")_" "_$P(PSOTIME,"@",2)
90 .S PSOTIME=$P(PSOTIME,":",1,2)
91 .I ($Y+5)>IOSL&('$G(PSOOUT)) D TITLEA I PSOOUT Q
92 .W !,?2,PSOTIME
93 .W ?25,$S(PSOSTAT:"YES",PSOSTAT=0:"NO",1:" ")
94 .S PSOIND=$P(PSONODE,"^",3)
95 .I 'PSOSTAT S PSOIND=""
96 .W ?35,$S(PSOIND="B":"BLIND VETERAN",PSOIND="L":"LOW VISION",1:"")
97 .I $P(PSONODE,"^",4)'="" D W ?52,$E(PSODUZ,1,27)
98 ..K DIC,X,Y S DIC="^VA(200,",DIC(0)="M",X="`"_+$P(PSONODE,"^",4) D ^DIC S PSODUZ=$S(+Y:$P(Y,"^",2),1:"UNKNOWN") K DIC,X,Y
99 I PSOOUT G DONE
100END ;
101 I '$G(PSOOUT),$G(PSODV)="C" W !!,"** End of Report **" K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
102 I $G(PSODV)="C" W !
103 E W @IOF
104DONE K PSOPT,PSOAUD,PSONODE,PSOIND,PSOSTAT,PSOPGCT,Y,IOP,POP,IO("Q"),DIRUT,DUOUT,DTOUT,PSODV,PSOOUT
105 K PSODFN,PSOIND,PSOSSN,PSOPRINT,PSONM,^TMP($J,"PSOTALK2")
106 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
107 Q
108 ;
109TITLEA ;
110 I $G(PSODV)="C",$G(PSOPGCT)'=1 W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSOOUT=1 Q
111 W @IOF
112 W !,"SCRIPTALK AUDIT HISTORY" S Y=DT X ^DD("DD") W ?40,"Date printed: ",Y,?70,"Page: ",PSOPGCT,!!
113 S PSOPGCT=PSOPGCT+1
114 W !,"Name: ",$E($P(^DPT(PSOPT,0),"^"),1,25)," Currently enrolled: ",$S($G(^PS(55,"ASTALK",PSOPT)):"YES",1:"NO"),!!
115 W !?24,"Previous",?35,"Previous"
116 W !,?2,"Date-Time Set",?25,"Status",?35,"Indication",?52,"Entered by"
117 W !,?2,"-------------------",?24,"--------",?35,"-------------",?52,"--------------------",!
118 Q
119 ;
120ENQ ;
121 W ! K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you want to report only active enrollees" D ^DIR K DIR D:$D(DIRUT) MESS G:Y["^"!($D(DIRUT)) DONE S PSOPRINT=$S(Y:1,1:0)
122 W !!,"You may queue the report to print, if you wish.",!
123 K %ZIS,POP,IOP S %ZIS="QM" D ^%ZIS I $G(POP) W !!,"Nothing queued to print.",! G DONE
124 I $D(IO("Q")) S ZTRTN="RPENROLL^PSOTALK2",ZTDESC="Report of ScripTalk Enrollment",ZTSAVE("*")="" D ^%ZTLOAD K %ZSI W !,"Report queued to print.",! G DONE
125RPENROLL ;
126 U IO
127 S PSOOUT=0,PSODV=$S($E(IOST)="C":"C",1:"P")
128 S PSOPGCT=1
129 D TITLEE I PSOOUT G DONE
130 K ^TMP($J,"PSOTALK2")
131 D GETDFN
132 I '$D(^TMP($J,"PSOTALK2")) W !!,"No patients to report!",!! G DONE
133 S PSONM="" F S PSONM=$O(^TMP($J,"PSOTALK2",PSONM)) Q:PSONM="" S PSOSSN="" F S PSOSSN=$O(^TMP($J,"PSOTALK2",PSONM,PSOSSN)) Q:PSOSSN="" D I PSOOUT G DONE
134 .S PSOIND=^TMP($J,"PSOTALK2",PSONM,PSOSSN)
135 .I ($Y+5)>IOSL&('$G(PSOOUT)) D TITLEE I PSOOUT Q
136 .W !,PSONM,?25," ",PSOSSN I 'PSOPRINT W ?43,$S(+$P(PSOIND,"^",3):"YES",1:"NO")
137 .W !,?3,$S($P(PSOIND,"^",2)="B":"BLIND VETERAN",$P(PSOIND,"^",2)="L":"LOW VISION",1:" ")
138 .W ?58,$$FMTE^XLFDT($P(PSOIND,"^")),!
139 G END
140 ;
141TITLEE ;
142 I $G(PSODV)="C",$G(PSOPGCT)'=1 W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSOOUT=1 Q
143 W @IOF
144 W !,"Report of ScripTalk Enrollment",?40,"Date printed: "_$$FMTE^XLFDT(DT),?70,"Page: ",PSOPGCT,!!
145 S PSOPGCT=PSOPGCT+1
146 W !,"Patient name",?25," SSN" I 'PSOPRINT W ?40,"Active enrollee?"
147 W !?3,"Indication",?57,"Enrollment last updated"
148 W !,"--------------",?25,"-----------" W:'PSOPRINT ?40,"-------------" W ?57,"-----------------------",!
149 Q
150 ;
151GETDFN ;
152 N DFN
153 S PSODFN=0 F S PSODFN=$O(^PS(55,"ASTALK",PSODFN)) Q:PSODFN="" D
154 .I PSOPRINT I '$G(^PS(55,"ASTALK",PSODFN)) Q
155 .S DFN=PSODFN D DEM^VADPT I +$G(VADM(6)) Q ; DECEASED
156 .S PSOSEQ=$P($G(^PS(55,DFN,"SCTALK",0)),"^",4)
157 .S PSOAUD=""
158 .I PSOSEQ'="" S PSOAUD=$G(^PS(55,DFN,"SCTALK",PSOSEQ,0))
159 .I $G(VA("PID"))="" S VA("PID")=" "
160 .S ^TMP($J,"PSOTALK2",VADM(1),VA("PID"))=$P(PSOAUD,"^")_"^"_$P(PSOAUD,"^",3)_"^"_$G(^PS(55,"ASTALK",PSODFN))
161 Q
162 ;
163MESS W !!,"No report printed!",!!
164 Q
165 ;
166MAIL ; MAKE SURE MAIL STATUS IS COMPATIBLE WITH SCRIPTALK PATIENT
167 N MAIL
168 S MAIL=$G(^PS(55,PSOPT,0)) I $P(MAIL,"^",3)>1 Q
169MAILP W !!,"REMINDER: CMOP does not fill ScripTalk prescriptions.Please select mail"
170 W !,"status: 2 (DO NOT MAIL), 3 (LOCAL REGULAR MAIL) or 4 (LOCAL CERTFIED MAIL)."
171 R !,"MAIL: ",MAIL:120
172 I MAIL?1"^".E Q
173 I MAIL<2!(MAIL>4) W !,"INVALID MAIL SETTING - ENTER 2,3, OR 4" G MAILP
174 W " ",$S(MAIL=2:"DO NOT MAIL",MAIL=3:"LOCAL REGULAR MAIL",1:"LOCAL CERTIFIED MAIL")
175 S $P(^PS(55,PSOPT,0),"^",3)=MAIL
176 Q
Note: See TracBrowser for help on using the repository browser.