PSOTPCLR ;BIRM/PDW-LETTER PRINT REPORTS ;AUG 8, 2003
;;7.0;OUTPATIENT PHARMACY;**145,227**;DEC 1997
Q
EN ;
Q ;placed out of order by patch PSO*7*227
K DIR S DIR(0)="SO^N:Patients/Letters NOT Printed;P:Patients/Letters Printed" D ^DIR
I Y="N" S PARAM=Y G DEVICE
I Y="P" S PARAM=Y G DEVICE
Q
DEVICE ;
W !,"Queuing is recommended",!
K %ZIS S %ZIS="Q" D ^%ZIS
Q:POP
I $D(IO("Q")) D K ZTSK G EXIT2
. S ZTRTN="DEQUE^PSOTPCLR",ZTDESC="TPB PRINT LETTER REPORT"
. S ZTSAVE("PARAM")=""
. D ^%ZTLOAD D ^%ZISC
. I $G(ZTSK) W !!,"Tasked with "_ZTSK
;
DEQUE ; DEQUE/PRINT LETTERS
K ^TMP($J,"PSOTPBLR"),DIVCNT
S DIVDA=0 F S DIVDA=$O(^PS(52.91,"AC",DIVDA)) Q:DIVDA'>0 D
. S DFN=0 F S DFN=$O(^PS(52.91,"AC",DIVDA,DFN)) Q:DFN'>0 D
.. S PRTDTI=$$GET1^DIQ(52.91,DFN,11,"I") I PARAM="P",'PRTDTI Q
.. S PRTDTI=$$GET1^DIQ(52.91,DFN,11,"I") I PARAM="N",PRTDTI Q
.. S PTNM=$$GET1^DIQ(52.91,DFN,.01),PRTDT=$$FMTE^XLFDT(PRTDTI,"2D")
.. S ^TMP($J,"PSOTPBLR",DIVDA,PTNM,DFN)=PRTDT
.. S DIVCNT(DIVDA)=$G(DIVCNT(DIVDA))+1
PRINT ; print report
U IO K DIVCNT,PSOSTOP
S PG=0,LINE="",$P(LINE,"=",79)=""
S DIVDA=0 F Q:$G(PSOSTOP) S DIVDA=$O(^TMP($J,"PSOTPBLR",DIVDA)) Q:DIVDA'>0 D
. D HEADER
. S PTNM="" F Q:$G(PSOSTOP) S PTNM=$O(^TMP($J,"PSOTPBLR",DIVDA,PTNM)) Q:PTNM="" D
.. S DFN=0 F Q:$G(PSOSTOP) S DFN=$O(^TMP($J,"PSOTPBLR",DIVDA,PTNM,DFN)) Q:DFN'>0 D
... S DIVCNT(DIVDA)=$G(DIVCNT(DIVDA))+1
... D PG
... W !,$$GET1^DIQ(52.91,DFN,.01)
... I PARAM="P" W ?35,^TMP($J,"PSOTPBLR",DIVDA,PTNM,DFN) Q
... S INACTDT=$$GET1^DIQ(52.91,DFN,2,"I"),EXCODE=$$GET1^DIQ(52.91,DFN,3),EXREA=$$GET1^DIQ(52.91,DFN,8)
... W:INACTDT ?35,$$FMTE^XLFDT(INACTDT,"2D") W:$L(EXCODE) ?45,EXCODE
... W:$L(EXREA) !,?10,"Exclusion Reason: ",EXREA
SUMMARY ;
W:'$D(DIVCNT) !!,"No Data Found"
Q:$G(PSOSTOP)
I PG,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR I 'Y S PSOSTOP=1 Q
W !,@IOF,!!,?10,"SUMMARY of TPB LETTER PRINTING "
I PARAM="P" W "'PRINTED'" I 1
E W "'NOT PRINTED'"
W !!
S DIVDA=0 F S DIVDA=$O(DIVCNT(DIVDA)) Q:DIVDA'>0 D
. W !,?5,$$GET1^DIQ(52.92,DIVDA,.01),?40,DIVCNT(DIVDA)
W:'$D(DIVCNT) !!,"No Data Found"
W !
G EXIT
;
PG I $Y>(IOSL-4) D HEADER
Q
W !
I PG,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR I 'Y S PSOSTOP=1 Q
W @IOF
S PG=PG+1
W ?20,$$GET1^DIQ(52.92,DIVDA,.01)
I PARAM="P" W " TPB PATIENTS LETTERS PRINTED REPORT",! I 1
E W " TPB PATIENTS LETTERS NOT PRINTED REPORT",!
W ?28,$$FMTE^XLFDT(DT,"1D"),?60,"Page: ",PG,!,LINE
I PARAM="N" W !,?35,"Inactivation",!,"Patient",?35,"Date",?45,"Reason",!
Q
EXIT ;
I $E(IOST)="C" W !!,"End of Report",! K DIR S DIR(0)="EO",DIR("A")="<cr> - Continue" D ^DIR
K ^TMP($J,"PSOTPBLR") I $G(ZTSK) D KILL^%ZTLOAD
EXIT2 D ^%ZISC
K DIR,DIVCNT,DIVDA,LINE,PARAM,PG,PRTDT,PRTDTI,PTNM,SRDT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOTPCLR 2834 printed Sep 23, 2025@20:12:15 Page 2
PSOTPCLR ;BIRM/PDW-LETTER PRINT REPORTS ;AUG 8, 2003
+1 ;;7.0;OUTPATIENT PHARMACY;**145,227**;DEC 1997
+2 QUIT
EN ;
+1 ;placed out of order by patch PSO*7*227
QUIT
+2 KILL DIR
SET DIR(0)="SO^N:Patients/Letters NOT Printed;P:Patients/Letters Printed"
DO ^DIR
+3 IF Y="N"
SET PARAM=Y
GOTO DEVICE
+4 IF Y="P"
SET PARAM=Y
GOTO DEVICE
+5 QUIT
DEVICE ;
+1 WRITE !,"Queuing is recommended",!
+2 KILL %ZIS
SET %ZIS="Q"
DO ^%ZIS
+3 if POP
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTRTN="DEQUE^PSOTPCLR"
SET ZTDESC="TPB PRINT LETTER REPORT"
+6 SET ZTSAVE("PARAM")=""
+7 DO ^%ZTLOAD
DO ^%ZISC
+8 IF $GET(ZTSK)
WRITE !!,"Tasked with "_ZTSK
End DoDot:1
KILL ZTSK
GOTO EXIT2
+9 ;
DEQUE ; DEQUE/PRINT LETTERS
+1 KILL ^TMP($JOB,"PSOTPBLR"),DIVCNT
+2 SET DIVDA=0
FOR
SET DIVDA=$ORDER(^PS(52.91,"AC",DIVDA))
if DIVDA'>0
QUIT
Begin DoDot:1
+3 SET DFN=0
FOR
SET DFN=$ORDER(^PS(52.91,"AC",DIVDA,DFN))
if DFN'>0
QUIT
Begin DoDot:2
+4 SET PRTDTI=$$GET1^DIQ(52.91,DFN,11,"I")
IF PARAM="P"
IF 'PRTDTI
QUIT
+5 SET PRTDTI=$$GET1^DIQ(52.91,DFN,11,"I")
IF PARAM="N"
IF PRTDTI
QUIT
+6 SET PTNM=$$GET1^DIQ(52.91,DFN,.01)
SET PRTDT=$$FMTE^XLFDT(PRTDTI,"2D")
+7 SET ^TMP($JOB,"PSOTPBLR",DIVDA,PTNM,DFN)=PRTDT
+8 SET DIVCNT(DIVDA)=$GET(DIVCNT(DIVDA))+1
End DoDot:2
End DoDot:1
PRINT ; print report
+1 USE IO
KILL DIVCNT,PSOSTOP
+2 SET PG=0
SET LINE=""
SET $PIECE(LINE,"=",79)=""
+3 SET DIVDA=0
FOR
if $GET(PSOSTOP)
QUIT
SET DIVDA=$ORDER(^TMP($JOB,"PSOTPBLR",DIVDA))
if DIVDA'>0
QUIT
Begin DoDot:1
+4 DO HEADER
+5 SET PTNM=""
FOR
if $GET(PSOSTOP)
QUIT
SET PTNM=$ORDER(^TMP($JOB,"PSOTPBLR",DIVDA,PTNM))
if PTNM=""
QUIT
Begin DoDot:2
+6 SET DFN=0
FOR
if $GET(PSOSTOP)
QUIT
SET DFN=$ORDER(^TMP($JOB,"PSOTPBLR",DIVDA,PTNM,DFN))
if DFN'>0
QUIT
Begin DoDot:3
+7 SET DIVCNT(DIVDA)=$GET(DIVCNT(DIVDA))+1
+8 DO PG
+9 WRITE !,$$GET1^DIQ(52.91,DFN,.01)
+10 IF PARAM="P"
WRITE ?35,^TMP($JOB,"PSOTPBLR",DIVDA,PTNM,DFN)
QUIT
+11 SET INACTDT=$$GET1^DIQ(52.91,DFN,2,"I")
SET EXCODE=$$GET1^DIQ(52.91,DFN,3)
SET EXREA=$$GET1^DIQ(52.91,DFN,8)
+12 if INACTDT
WRITE ?35,$$FMTE^XLFDT(INACTDT,"2D")
if $LENGTH(EXCODE)
WRITE ?45,EXCODE
+13 if $LENGTH(EXREA)
WRITE !,?10,"Exclusion Reason: ",EXREA
End DoDot:3
End DoDot:2
End DoDot:1
SUMMARY ;
+1 if '$DATA(DIVCNT)
WRITE !!,"No Data Found"
+2 if $GET(PSOSTOP)
QUIT
+3 IF PG
IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET PSOSTOP=1
QUIT
+4 WRITE !,@IOF,!!,?10,"SUMMARY of TPB LETTER PRINTING "
+5 IF PARAM="P"
WRITE "'PRINTED'"
IF 1
+6 IF '$TEST
WRITE "'NOT PRINTED'"
+7 WRITE !!
+8 SET DIVDA=0
FOR
SET DIVDA=$ORDER(DIVCNT(DIVDA))
if DIVDA'>0
QUIT
Begin DoDot:1
+9 WRITE !,?5,$$GET1^DIQ(52.92,DIVDA,.01),?40,DIVCNT(DIVDA)
End DoDot:1
+10 if '$DATA(DIVCNT)
WRITE !!,"No Data Found"
+11 WRITE !
+12 GOTO EXIT
+13 ;
PG IF $Y>(IOSL-4)
DO HEADER
+1 QUIT
+1 WRITE !
+2 IF PG
IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET PSOSTOP=1
QUIT
+3 WRITE @IOF
+4 SET PG=PG+1
+5 WRITE ?20,$$GET1^DIQ(52.92,DIVDA,.01)
+6 IF PARAM="P"
WRITE " TPB PATIENTS LETTERS PRINTED REPORT",!
IF 1
+7 IF '$TEST
WRITE " TPB PATIENTS LETTERS NOT PRINTED REPORT",!
+8 WRITE ?28,$$FMTE^XLFDT(DT,"1D"),?60,"Page: ",PG,!,LINE
+9 IF PARAM="N"
WRITE !,?35,"Inactivation",!,"Patient",?35,"Date",?45,"Reason",!
+10 QUIT
EXIT ;
+1 IF $EXTRACT(IOST)="C"
WRITE !!,"End of Report",!
KILL DIR
SET DIR(0)="EO"
SET DIR("A")="<cr> - Continue"
DO ^DIR
+2 KILL ^TMP($JOB,"PSOTPBLR")
IF $GET(ZTSK)
DO KILL^%ZTLOAD
EXIT2 DO ^%ZISC
+1 KILL DIR,DIVCNT,DIVDA,LINE,PARAM,PG,PRTDT,PRTDTI,PTNM,SRDT
+2 QUIT
