- 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 Feb 19, 2025@00:02:13 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