PSOTALK2 ;BIR/EJW - SCRIPTALK ENROLLMENT FUNCTIONS ;3-28-02
;;7.0;OUTPATIENT PHARMACY;**135,182,326**;DEC 1997;Build 11
;External reference ^PS(55 supported by DBIA 2228
;External reference ^TMP("TIUP", ^TIUPNAPI, ^TIU(8925.1 supported by DBIA 1911
ENROLL ;
N PSOSTEN,PSOIND,PSOLAST,DFN
S PSOIND=""
I '$G(PSOFIRST) D INSTR S PSOFIRST=1
W !
K DIC W ! S DIC(0)="QEAM",DIC("A")="Select PATIENT: " D EN^PSOPATLK S Y=PSOPTLK K DIC,PSOPTLK I Y<1!($D(DUOUT))!($D(DTOUT)) D CLEAN Q
S PSOPT=+Y
S DFN=PSOPT D DEM^VADPT I +$G(VADM(6)) W !,"Patient is deceased",! G ENROLL
I '$D(^PS(55,PSOPT)) D
.S DIC="^PS(55,",DLAYGO=55
.K DD,DO S DIC(0)="L",(DINUM,X)=PSOPT D FILE^DICN D:Y<1 K DIC,DA,DR,DD,DO
..S $P(^PS(55,PSOPT,0),"^")=PSOPT K DIK S DA=PSOPT,DIK="^PS(55,",DIK(1)=.01 D EN^DIK K DIK
S PSOSTEN=$G(^PS(55,"ASTALK",PSOPT))
S DIR(0)="Y",DIR("A")="SCRIPTALK PATIENT" S DIR("B")=$S(PSOSTEN:"Y",1:"N") D ^DIR K DIR
S PSOSTEN=Y
I PSOSTEN D MAIL,GETIND
D SET55
D NOTE(PSOPT)
K PSOIND,PSOPT,PSOSTEN,PSOLAST,X,Y
G ENROLL
;
SET55 ; SET MULTIPLE FOR SCRIPTALK ENROLLMENT AUDIT
N PSODA,PSOERR,PSOIEN,PSOSTDT
I PSOPT="" Q
S PSOSTDT=$$NOW^XLFDT
S PSODA(55.0108,"+1,"_PSOPT_",",.01)=PSOSTDT
S PSODA(55.0108,"+1,"_PSOPT_",",1)=PSOSTEN
S PSODA(55.0108,"+1,"_PSOPT_",",2)=PSOIND
S PSODA(55.0108,"+1,"_PSOPT_",",3)=$G(DUZ)
D UPDATE^DIE("","PSODA","PSOIEN","PSOERR")
Q
;
GETIND ; GET INDICATION FOR ENROLLMENT
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
S DIR(0)="S^B:BLIND VETERAN;L:LOW VISION",DIR("A")="INDICATION" S DIR("B")=PSOIND D ^DIR K DIR
S PSOIND=$G(Y)
Q
;
INSTR ;
W @IOF
I $O(^TIU(8925.1,"B","SCRIPTALK ENROLLMENT",0))="" Q
W !
W !?3,"At the conclusion of this enrollment option, you will be given"
W !?3,"the opportunity to sign a progress note recording the enrollment"
W !?3,"of new ScripTalk patients. If you modify the record of a patient"
W !?3,"that was previously enrolled, and they remain enrolled, you may"
W !?3,"wish to either delete or edit the text of the generated note."
W !!
K PSOSQ,PSOTT,PSOSTP
Q
;
NOTE(PSOPT) ;CREATE A PROGRESS NOTE FOR PATIENT 'PSOPT' ABOUT ENROLLMENT
Q:'+$G(^PS(55,"ASTALK",PSOPT)) ; IF THIS PTS ENROLLMENT ISN'T ACTIVE
S PSOTITL=$O(^TIU(8925.1,"B","SCRIPTALK ENROLLMENT",0))
Q:'+PSOTITL ;IF NO TITLE ON SYSTEM
S PSOPTNM=$P($G(^DPT(PSOPT,0)),U,1)
S PSOLINE=1
S ^TMP("TIUP",$J,PSOLINE,0)=PSOPTNM_" was enrolled in ScripTalk today, and is now eligible to receive"
S PSOLINE=PSOLINE+1
S ^TMP("TIUP",$J,PSOLINE,0)="prescriptions with encoded speech-capable labels."
S ^TMP("TIUP",$J,0)=U_U_PSOLINE_PSOLINE_U_DT_U
INSTALL K TIUDA
D NEW^TIUPNAPI(.TIUDA,PSOPT,DUZ,$$NOW^XLFDT,PSOTITL)
Q
;
CLEAN K PSOLINE,PSOPTNM,PSOTITL,PSOSTP,PSOPT,PSOFIRST
K ^TMP("TIUP",$J)
Q
;
AUDREP ;
K DIC W ! S DIC(0)="QEAM",DIC("A")="Select PATIENT: " D EN^PSOPATLK S Y=PSOPTLK K DIC,PSOPTLK I Y<1!($D(DUOUT))!($D(DTOUT)) Q
S PSOPT=+Y
S ZTSAVE("*")=""
W !!,"You may queue the report to print, if you wish.",!
K %ZIS,POP,IOP S %ZIS="QM" D ^%ZIS I $G(POP) W !!,"Nothing queued to print.",! G DONE
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
AUDRQ ;
U IO
S PSOOUT=0,PSODV=$S($E(IOST)="C":"C",1:"P")
S PSOPGCT=1
D TITLEA I PSOOUT G DONE
S PSOAUD=0 F S PSOAUD=$O(^PS(55,PSOPT,"SCTALK",PSOAUD)) Q:PSOAUD="" D I PSOOUT Q
.S PSONODE=$G(^PS(55,PSOPT,"SCTALK",PSOAUD,0))
.S PSOSTAT=$P(PSONODE,"^",2)
.S PSOTIME=$$FMTE^XLFDT($P(PSONODE,U,1)),PSOTIME=$P(PSOTIME,"@")_" "_$P(PSOTIME,"@",2)
.S PSOTIME=$P(PSOTIME,":",1,2)
.I ($Y+5)>IOSL&('$G(PSOOUT)) D TITLEA I PSOOUT Q
.W !,?2,PSOTIME
.W ?25,$S(PSOSTAT:"YES",PSOSTAT=0:"NO",1:" ")
.S PSOIND=$P(PSONODE,"^",3)
.I 'PSOSTAT S PSOIND=""
.W ?35,$S(PSOIND="B":"BLIND VETERAN",PSOIND="L":"LOW VISION",1:"")
.I $P(PSONODE,"^",4)'="" D W ?52,$E(PSODUZ,1,27)
..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
I PSOOUT G DONE
END ;
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
I $G(PSODV)="C" W !
E W @IOF
DONE K PSOPT,PSOAUD,PSONODE,PSOIND,PSOSTAT,PSOPGCT,Y,IOP,POP,IO("Q"),DIRUT,DUOUT,DTOUT,PSODV,PSOOUT
K PSODFN,PSOIND,PSOSSN,PSOPRINT,PSONM,^TMP($J,"PSOTALK2")
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
;
TITLEA ;
I $G(PSODV)="C",$G(PSOPGCT)'=1 W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSOOUT=1 Q
W @IOF
W !,"SCRIPTALK AUDIT HISTORY" S Y=DT X ^DD("DD") W ?40,"Date printed: ",Y,?70,"Page: ",PSOPGCT,!!
S PSOPGCT=PSOPGCT+1
W !,"Name: ",$E($P(^DPT(PSOPT,0),"^"),1,25)," Currently enrolled: ",$S($G(^PS(55,"ASTALK",PSOPT)):"YES",1:"NO"),!!
W !?24,"Previous",?35,"Previous"
W !,?2,"Date-Time Set",?25,"Status",?35,"Indication",?52,"Entered by"
W !,?2,"-------------------",?24,"--------",?35,"-------------",?52,"--------------------",!
Q
;
ENQ ;
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)
W !!,"You may queue the report to print, if you wish.",!
K %ZIS,POP,IOP S %ZIS="QM" D ^%ZIS I $G(POP) W !!,"Nothing queued to print.",! G DONE
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
RPENROLL ;
U IO
S PSOOUT=0,PSODV=$S($E(IOST)="C":"C",1:"P")
S PSOPGCT=1
D TITLEE I PSOOUT G DONE
K ^TMP($J,"PSOTALK2")
D GETDFN
I '$D(^TMP($J,"PSOTALK2")) W !!,"No patients to report!",!! G DONE
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
.S PSOIND=^TMP($J,"PSOTALK2",PSONM,PSOSSN)
.I ($Y+5)>IOSL&('$G(PSOOUT)) D TITLEE I PSOOUT Q
.W !,PSONM,?25," ",PSOSSN I 'PSOPRINT W ?43,$S(+$P(PSOIND,"^",3):"YES",1:"NO")
.W !,?3,$S($P(PSOIND,"^",2)="B":"BLIND VETERAN",$P(PSOIND,"^",2)="L":"LOW VISION",1:" ")
.W ?58,$$FMTE^XLFDT($P(PSOIND,"^")),!
G END
;
TITLEE ;
I $G(PSODV)="C",$G(PSOPGCT)'=1 W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSOOUT=1 Q
W @IOF
W !,"Report of ScripTalk Enrollment",?40,"Date printed: "_$$FMTE^XLFDT(DT),?70,"Page: ",PSOPGCT,!!
S PSOPGCT=PSOPGCT+1
W !,"Patient name",?25," SSN" I 'PSOPRINT W ?40,"Active enrollee?"
W !?3,"Indication",?57,"Enrollment last updated"
W !,"--------------",?25,"-----------" W:'PSOPRINT ?40,"-------------" W ?57,"-----------------------",!
Q
;
GETDFN ;
N DFN
S PSODFN=0 F S PSODFN=$O(^PS(55,"ASTALK",PSODFN)) Q:PSODFN="" D
.I PSOPRINT I '$G(^PS(55,"ASTALK",PSODFN)) Q
.S DFN=PSODFN D DEM^VADPT I +$G(VADM(6)) Q ; DECEASED
.S PSOSEQ=$P($G(^PS(55,DFN,"SCTALK",0)),"^",4)
.S PSOAUD=""
.I PSOSEQ'="" S PSOAUD=$G(^PS(55,DFN,"SCTALK",PSOSEQ,0))
.I $G(VA("PID"))="" S VA("PID")=" "
.S ^TMP($J,"PSOTALK2",VADM(1),VA("PID"))=$P(PSOAUD,"^")_"^"_$P(PSOAUD,"^",3)_"^"_$G(^PS(55,"ASTALK",PSODFN))
Q
;
MESS W !!,"No report printed!",!!
Q
;
MAIL ; MAKE SURE MAIL STATUS IS COMPATIBLE WITH SCRIPTALK PATIENT
N MAIL
S MAIL=$G(^PS(55,PSOPT,0)) I $P(MAIL,"^",3)>1 Q
MAILP W !!,"REMINDER: CMOP does not fill ScripTalk prescriptions.Please select mail"
W !,"status: 2 (DO NOT MAIL), 3 (LOCAL REGULAR MAIL) or 4 (LOCAL CERTFIED MAIL)."
R !,"MAIL: ",MAIL:120
I MAIL?1"^".E Q
I MAIL<2!(MAIL>4) W !,"INVALID MAIL SETTING - ENTER 2,3, OR 4" G MAILP
W " ",$S(MAIL=2:"DO NOT MAIL",MAIL=3:"LOCAL REGULAR MAIL",1:"LOCAL CERTIFIED MAIL")
S $P(^PS(55,PSOPT,0),"^",3)=MAIL
Q
PSOTALK2 ;BIR/EJW - SCRIPTALK ENROLLMENT FUNCTIONS ;3-28-02
+1 ;;7.0;OUTPATIENT PHARMACY;**135,182,326**;DEC 1997;Build 11
+2 ;External reference ^PS(55 supported by DBIA 2228
+3 ;External reference ^TMP("TIUP", ^TIUPNAPI, ^TIU(8925.1 supported by DBIA 1911
ENROLL ;
+1 NEW PSOSTEN,PSOIND,PSOLAST,DFN
+2 SET PSOIND=""
+3 IF '$GET(PSOFIRST)
DO INSTR
SET PSOFIRST=1
+4 WRITE !
+5 KILL DIC
WRITE !
SET DIC(0)="QEAM"
SET DIC("A")="Select PATIENT: "
DO EN^PSOPATLK
SET Y=PSOPTLK
KILL DIC,PSOPTLK
IF Y<1!($DATA(DUOUT))!($DATA(DTOUT))
DO CLEAN
QUIT
+6 SET PSOPT=+Y
+7 SET DFN=PSOPT
DO DEM^VADPT
IF +$GET(VADM(6))
WRITE !,"Patient is deceased",!
GOTO ENROLL
+8 IF '$DATA(^PS(55,PSOPT))
Begin DoDot:1
+9 SET DIC="^PS(55,"
SET DLAYGO=55
+10 KILL DD,DO
SET DIC(0)="L"
SET (DINUM,X)=PSOPT
DO FILE^DICN
IF Y<1
Begin DoDot:2
+11 SET $PIECE(^PS(55,PSOPT,0),"^")=PSOPT
KILL DIK
SET DA=PSOPT
SET DIK="^PS(55,"
SET DIK(1)=.01
DO EN^DIK
KILL DIK
End DoDot:2
KILL DIC,DA,DR,DD,DO
End DoDot:1
+12 SET PSOSTEN=$GET(^PS(55,"ASTALK",PSOPT))
+13 SET DIR(0)="Y"
SET DIR("A")="SCRIPTALK PATIENT"
SET DIR("B")=$SELECT(PSOSTEN:"Y",1:"N")
DO ^DIR
KILL DIR
+14 SET PSOSTEN=Y
+15 IF PSOSTEN
DO MAIL
DO GETIND
+16 DO SET55
+17 DO NOTE(PSOPT)
+18 KILL PSOIND,PSOPT,PSOSTEN,PSOLAST,X,Y
+19 GOTO ENROLL
+20 ;
SET55 ; SET MULTIPLE FOR SCRIPTALK ENROLLMENT AUDIT
+1 NEW PSODA,PSOERR,PSOIEN,PSOSTDT
+2 IF PSOPT=""
QUIT
+3 SET PSOSTDT=$$NOW^XLFDT
+4 SET PSODA(55.0108,"+1,"_PSOPT_",",.01)=PSOSTDT
+5 SET PSODA(55.0108,"+1,"_PSOPT_",",1)=PSOSTEN
+6 SET PSODA(55.0108,"+1,"_PSOPT_",",2)=PSOIND
+7 SET PSODA(55.0108,"+1,"_PSOPT_",",3)=$GET(DUZ)
+8 DO UPDATE^DIE("","PSODA","PSOIEN","PSOERR")
+9 QUIT
+10 ;
GETIND ; GET INDICATION FOR ENROLLMENT
+1 ; IF PRIOR ANSWER WAS 'Y' - GET PRIOR INDICATION
SET PSOLAST=$PIECE($GET(^PS(55,PSOPT,"SCTALK",0)),"^",4)
IF PSOLAST'=""
SET PSOIND=$PIECE($GET(^PS(55,PSOPT,"SCTALK",PSOLAST,0)),"^",3)
+2 SET DIR(0)="S^B:BLIND VETERAN;L:LOW VISION"
SET DIR("A")="INDICATION"
SET DIR("B")=PSOIND
DO ^DIR
KILL DIR
+3 SET PSOIND=$GET(Y)
+4 QUIT
+5 ;
INSTR ;
+1 WRITE @IOF
+2 IF $ORDER(^TIU(8925.1,"B","SCRIPTALK ENROLLMENT",0))=""
QUIT
+3 WRITE !
+4 WRITE !?3,"At the conclusion of this enrollment option, you will be given"
+5 WRITE !?3,"the opportunity to sign a progress note recording the enrollment"
+6 WRITE !?3,"of new ScripTalk patients. If you modify the record of a patient"
+7 WRITE !?3,"that was previously enrolled, and they remain enrolled, you may"
+8 WRITE !?3,"wish to either delete or edit the text of the generated note."
+9 WRITE !!
+10 KILL PSOSQ,PSOTT,PSOSTP
+11 QUIT
+12 ;
NOTE(PSOPT) ;CREATE A PROGRESS NOTE FOR PATIENT 'PSOPT' ABOUT ENROLLMENT
+1 ; IF THIS PTS ENROLLMENT ISN'T ACTIVE
IF '+$GET(^PS(55,"ASTALK",PSOPT))
QUIT
+2 SET PSOTITL=$ORDER(^TIU(8925.1,"B","SCRIPTALK ENROLLMENT",0))
+3 ;IF NO TITLE ON SYSTEM
IF '+PSOTITL
QUIT
+4 SET PSOPTNM=$PIECE($GET(^DPT(PSOPT,0)),U,1)
+5 SET PSOLINE=1
+6 SET ^TMP("TIUP",$JOB,PSOLINE,0)=PSOPTNM_" was enrolled in ScripTalk today, and is now eligible to receive"
+7 SET PSOLINE=PSOLINE+1
+8 SET ^TMP("TIUP",$JOB,PSOLINE,0)="prescriptions with encoded speech-capable labels."
+9 SET ^TMP("TIUP",$JOB,0)=U_U_PSOLINE_PSOLINE_U_DT_U
INSTALL KILL TIUDA
+1 DO NEW^TIUPNAPI(.TIUDA,PSOPT,DUZ,$$NOW^XLFDT,PSOTITL)
+2 QUIT
+3 ;
CLEAN KILL PSOLINE,PSOPTNM,PSOTITL,PSOSTP,PSOPT,PSOFIRST
+1 KILL ^TMP("TIUP",$JOB)
+2 QUIT
+3 ;
AUDREP ;
+1 KILL DIC
WRITE !
SET DIC(0)="QEAM"
SET DIC("A")="Select PATIENT: "
DO EN^PSOPATLK
SET Y=PSOPTLK
KILL DIC,PSOPTLK
IF Y<1!($DATA(DUOUT))!($DATA(DTOUT))
QUIT
+2 SET PSOPT=+Y
+3 SET ZTSAVE("*")=""
+4 WRITE !!,"You may queue the report to print, if you wish.",!
+5 KILL %ZIS,POP,IOP
SET %ZIS="QM"
DO ^%ZIS
IF $GET(POP)
WRITE !!,"Nothing queued to print.",!
GOTO DONE
+6 IF $DATA(IO("Q"))
SET ZTRTN="AUDRQ^PSOTALK2"
SET ZTDESC="Report of ScripTalk Enrollment"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
KILL %ZSI
WRITE !,"Report queued to print.",!
GOTO DONE
AUDRQ ;
+1 USE IO
+2 SET PSOOUT=0
SET PSODV=$SELECT($EXTRACT(IOST)="C":"C",1:"P")
+3 SET PSOPGCT=1
+4 DO TITLEA
IF PSOOUT
GOTO DONE
+5 SET PSOAUD=0
FOR
SET PSOAUD=$ORDER(^PS(55,PSOPT,"SCTALK",PSOAUD))
IF PSOAUD=""
QUIT
Begin DoDot:1
+6 SET PSONODE=$GET(^PS(55,PSOPT,"SCTALK",PSOAUD,0))
+7 SET PSOSTAT=$PIECE(PSONODE,"^",2)
+8 SET PSOTIME=$$FMTE^XLFDT($PIECE(PSONODE,U,1))
SET PSOTIME=$PIECE(PSOTIME,"@")_" "_$PIECE(PSOTIME,"@",2)
+9 SET PSOTIME=$PIECE(PSOTIME,":",1,2)
+10 IF ($Y+5)>IOSL&('$GET(PSOOUT))
DO TITLEA
IF PSOOUT
QUIT
+11 WRITE !,?2,PSOTIME
+12 WRITE ?25,$SELECT(PSOSTAT:"YES",PSOSTAT=0:"NO",1:" ")
+13 SET PSOIND=$PIECE(PSONODE,"^",3)
+14 IF 'PSOSTAT
SET PSOIND=""
+15 WRITE ?35,$SELECT(PSOIND="B":"BLIND VETERAN",PSOIND="L":"LOW VISION",1:"")
+16 IF $PIECE(PSONODE,"^",4)'=""
Begin DoDot:2
+17 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="M"
SET X="`"_+$PIECE(PSONODE,"^",4)
DO ^DIC
SET PSODUZ=$SELECT(+Y:$PIECE(Y,"^",2),1:"UNKNOWN")
KILL DIC,X,Y
End DoDot:2
WRITE ?52,$EXTRACT(PSODUZ,1,27)
End DoDot:1
IF PSOOUT
QUIT
+18 IF PSOOUT
GOTO DONE
END ;
+1 IF '$GET(PSOOUT)
IF $GET(PSODV)="C"
WRITE !!,"** End of Report **"
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+2 IF $GET(PSODV)="C"
WRITE !
+3 IF '$TEST
WRITE @IOF
DONE KILL PSOPT,PSOAUD,PSONODE,PSOIND,PSOSTAT,PSOPGCT,Y,IOP,POP,IO("Q"),DIRUT,DUOUT,DTOUT,PSODV,PSOOUT
+1 KILL PSODFN,PSOIND,PSOSSN,PSOPRINT,PSONM,^TMP($JOB,"PSOTALK2")
+2 DO ^%ZISC
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
+4 ;
TITLEA ;
+1 IF $GET(PSODV)="C"
IF $GET(PSOPGCT)'=1
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSOOUT=1
QUIT
+2 WRITE @IOF
+3 WRITE !,"SCRIPTALK AUDIT HISTORY"
SET Y=DT
XECUTE ^DD("DD")
WRITE ?40,"Date printed: ",Y,?70,"Page: ",PSOPGCT,!!
+4 SET PSOPGCT=PSOPGCT+1
+5 WRITE !,"Name: ",$EXTRACT($PIECE(^DPT(PSOPT,0),"^"),1,25)," Currently enrolled: ",$SELECT($GET(^PS(55,"ASTALK",PSOPT)):"YES",1:"NO"),!!
+6 WRITE !?24,"Previous",?35,"Previous"
+7 WRITE !,?2,"Date-Time Set",?25,"Status",?35,"Indication",?52,"Entered by"
+8 WRITE !,?2,"-------------------",?24,"--------",?35,"-------------",?52,"--------------------",!
+9 QUIT
+10 ;
ENQ ;
+1 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Do you want to report only active enrollees"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO MESS
IF Y["^"!($DATA(DIRUT))
GOTO DONE
SET PSOPRINT=$SELECT(Y:1,1:0)
+2 WRITE !!,"You may queue the report to print, if you wish.",!
+3 KILL %ZIS,POP,IOP
SET %ZIS="QM"
DO ^%ZIS
IF $GET(POP)
WRITE !!,"Nothing queued to print.",!
GOTO DONE
+4 IF $DATA(IO("Q"))
SET ZTRTN="RPENROLL^PSOTALK2"
SET ZTDESC="Report of ScripTalk Enrollment"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
KILL %ZSI
WRITE !,"Report queued to print.",!
GOTO DONE
RPENROLL ;
+1 USE IO
+2 SET PSOOUT=0
SET PSODV=$SELECT($EXTRACT(IOST)="C":"C",1:"P")
+3 SET PSOPGCT=1
+4 DO TITLEE
IF PSOOUT
GOTO DONE
+5 KILL ^TMP($JOB,"PSOTALK2")
+6 DO GETDFN
+7 IF '$DATA(^TMP($JOB,"PSOTALK2"))
WRITE !!,"No patients to report!",!!
GOTO DONE
+8 SET PSONM=""
FOR
SET PSONM=$ORDER(^TMP($JOB,"PSOTALK2",PSONM))
IF PSONM=""
QUIT
SET PSOSSN=""
FOR
SET PSOSSN=$ORDER(^TMP($JOB,"PSOTALK2",PSONM,PSOSSN))
IF PSOSSN=""
QUIT
Begin DoDot:1
+9 SET PSOIND=^TMP($JOB,"PSOTALK2",PSONM,PSOSSN)
+10 IF ($Y+5)>IOSL&('$GET(PSOOUT))
DO TITLEE
IF PSOOUT
QUIT
+11 WRITE !,PSONM,?25," ",PSOSSN
IF 'PSOPRINT
WRITE ?43,$SELECT(+$PIECE(PSOIND,"^",3):"YES",1:"NO")
+12 WRITE !,?3,$SELECT($PIECE(PSOIND,"^",2)="B":"BLIND VETERAN",$PIECE(PSOIND,"^",2)="L":"LOW VISION",1:" ")
+13 WRITE ?58,$$FMTE^XLFDT($PIECE(PSOIND,"^")),!
End DoDot:1
IF PSOOUT
GOTO DONE
+14 GOTO END
+15 ;
TITLEE ;
+1 IF $GET(PSODV)="C"
IF $GET(PSOPGCT)'=1
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSOOUT=1
QUIT
+2 WRITE @IOF
+3 WRITE !,"Report of ScripTalk Enrollment",?40,"Date printed: "_$$FMTE^XLFDT(DT),?70,"Page: ",PSOPGCT,!!
+4 SET PSOPGCT=PSOPGCT+1
+5 WRITE !,"Patient name",?25," SSN"
IF 'PSOPRINT
WRITE ?40,"Active enrollee?"
+6 WRITE !?3,"Indication",?57,"Enrollment last updated"
+7 WRITE !,"--------------",?25,"-----------"
IF 'PSOPRINT
WRITE ?40,"-------------"
WRITE ?57,"-----------------------",!
+8 QUIT
+9 ;
GETDFN ;
+1 NEW DFN
+2 SET PSODFN=0
FOR
SET PSODFN=$ORDER(^PS(55,"ASTALK",PSODFN))
IF PSODFN=""
QUIT
Begin DoDot:1
+3 IF PSOPRINT
IF '$GET(^PS(55,"ASTALK",PSODFN))
QUIT
+4 ; DECEASED
SET DFN=PSODFN
DO DEM^VADPT
IF +$GET(VADM(6))
QUIT
+5 SET PSOSEQ=$PIECE($GET(^PS(55,DFN,"SCTALK",0)),"^",4)
+6 SET PSOAUD=""
+7 IF PSOSEQ'=""
SET PSOAUD=$GET(^PS(55,DFN,"SCTALK",PSOSEQ,0))
+8 IF $GET(VA("PID"))=""
SET VA("PID")=" "
+9 SET ^TMP($JOB,"PSOTALK2",VADM(1),VA("PID"))=$PIECE(PSOAUD,"^")_"^"_$PIECE(PSOAUD,"^",3)_"^"_$GET(^PS(55,"ASTALK",PSODFN))
End DoDot:1
+10 QUIT
+11 ;
MESS WRITE !!,"No report printed!",!!
+1 QUIT
+2 ;
MAIL ; MAKE SURE MAIL STATUS IS COMPATIBLE WITH SCRIPTALK PATIENT
+1 NEW MAIL
+2 SET MAIL=$GET(^PS(55,PSOPT,0))
IF $PIECE(MAIL,"^",3)>1
QUIT
MAILP WRITE !!,"REMINDER: CMOP does not fill ScripTalk prescriptions.Please select mail"
+1 WRITE !,"status: 2 (DO NOT MAIL), 3 (LOCAL REGULAR MAIL) or 4 (LOCAL CERTFIED MAIL)."
+2 READ !,"MAIL: ",MAIL:120
+3 IF MAIL?1"^".E
QUIT
+4 IF MAIL<2!(MAIL>4)
WRITE !,"INVALID MAIL SETTING - ENTER 2,3, OR 4"
GOTO MAILP
+5 WRITE " ",$SELECT(MAIL=2:"DO NOT MAIL",MAIL=3:"LOCAL REGULAR MAIL",1:"LOCAL CERTIFIED MAIL")
+6 SET $PIECE(^PS(55,PSOPT,0),"^",3)=MAIL
+7 QUIT
