- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOTALK2 7857 printed Feb 19, 2025@00:02:07 Page 2
- 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
