PSOTPRP1 ;BIR/MR - Report of Patients with TPB and Non-TBP Active Rx's ;12/03/03
;;7.0;OUTPATIENT PHARMACY;**160,227**;DEC 1997
;
EN ;
Q ;placed out of order by PSO*7*227
N OINAM,INS,INSNAM,VADM,TYPE,DRGIEN,TPBRXCNT,SEQ,DFN,RXIEN,RXEXT,RX,POP
N PSOPAT,PSOAINS,PATNAM,PATCNT,PAT,PAG,INST,PATSSN,PSOAPT,VARXCNT,Y
;
W !!,"This report prints entries from the TPB ELIGIBILITY file (#52.91)."
W !,"If multiple Institutions are selected, and some Institutions have data and"
W !,"some don't, only those Institutions that have data will print on the report.",!
;
;Ask for Institutions
N DIC,X,I K PSOINS S PSOAINS=0
W !,?5,"You may select a single or multiple INSTITUTIONS,"
W !,?5,"or enter ^ALL to select all INSTITUTIONS.",!
S DIC=4,DIC(0)="QEAM",DIC("A")=" INSTITUTION: "
F D ^DIC Q:Y<0 S PSOINS(+Y)="" K DIC("B")
I X="^ALL" S PSOAINS=1 K PSOINS,DUOUT G PAT
I $D(DUOUT)!($D(DTOUT)) G END
I '$D(PSOINS)&(Y<0) G END
;
PAT ; - Selection of PATIENTS to print on the Report
N DIC,X,I K PSOPT S PSOAPT=0
W !!,?5,"You may select a single or multiple PATIENTS,"
W !,?5,"or enter ^ALL to select all PATIENTS.",!
S DIC=2,DIC(0)="QEAM",DIC("A")=" PATIENT: "
S DIC("S")="I $D(^PS(52.91,+Y))"
F D ^DIC Q:Y<0 S PSOPT(+Y)="" K DIC("B")
I X="^ALL" S PSOAPT=1 K PSOPT,DUOUT G DEV
I $D(DUOUT)!($D(DTOUT)) G END
I '$D(PSOPT)&(Y<0) G END
;
DEV W ! K %ZIS,IOP,POP,ZTSK S %ZIS="QM" D ^%ZIS K %ZIS I POP G END
I $D(IO("Q")) D G END
. N VAR K IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK S ZTRTN="RPT^PSOTPRP1"
. S ZTDESC="Report of Patients with TPB and Non-TPB Rx's"
. F VAR="PSOPT","PSOAPT","PSOINS","PSOAINS" S:$D(@VAR) ZTSAVE(VAR)=""
. S:$D(PSOPT) ZTSAVE("PSOPT(")="" S:$D(PSOINS) ZTSAVE("PSOINS(")=""
. D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!" K ZTSK
;
G RPT
;
END K ^TMP("PSOTPB",$J)
Q
;
RPT ;- Print the Report
;
SORT ;- Sort the Data by Institution,Patient Name
S DFN=0 K ^TMP("PSOTPB",$J)
;
;- ALL Patients
I PSOAPT D G PRINT
. F S DFN=$O(^PS(52.91,DFN)) Q:'DFN D STMP
;
;- Selected Patiens
F S DFN=$O(PSOPT(DFN)) Q:'DFN D STMP
;
PRINT ;- Read TMP global and Print Report
S PAG=0
I '$D(^TMP("PSOTPB",$J)) D G END
. D HDR W !!?30,"*** NO DATA TO PRINT ***"
;
S (INS,PAT,TYPE,RX)=""
F S INS=$O(^TMP("PSOTPB",$J,INS)) Q:INS="" D I $D(DIRUT) Q
. D HDR I $D(DIRUT) Q
. S (PATCNT,VARXCNT,TPBRXCNT)=0
. F S PAT=$O(^TMP("PSOTPB",$J,INS,PAT)) Q:PAT="" D I $D(DIRUT) Q
. . W !,PAT
. . F S TYPE=$O(^TMP("PSOTPB",$J,INS,PAT,TYPE)) Q:TYPE="" D I $D(DIRUT) Q
. . . F S RX=$O(^TMP("PSOTPB",$J,INS,PAT,TYPE,RX)) Q:RX="" D I $D(DIRUT) Q
. . . . I $Y>(IOSL-4) D HDR Q:$D(DIRUT) W !,PAT
. . . . S RXEXT=$$GET1^DIQ(52,RX,.01),DRGIEN=$$GET1^DIQ(52,RX,6)
. . . . S OINAM=$$GET1^DIQ(50,DRGIEN,2.1) S:OINAM="" OINAM=$$GET1^DIQ(52,RX,6)
. . . . W ?$S(TYPE=0:30,1:42),RXEXT,?54,$E(OINAM,1,26),!
. . . . S:TYPE=0 VARXCNT=VARXCNT+1 S:TYPE=1 TPBRXCNT=TPBRXCNT+1
. . S PATCNT=PATCNT+1
. I '$D(DIRUT) D
. . W !,"TOTAL ",INS,": ",PATCNT," Patient(s) ",VARXCNT," VA Prescriptions"
. . W TPBRXCNT," TPB Prescriptions."
Q
;
STMP ;- Set Temporary Global (^TMP)
;
;- Check the Patient Instituion
S INS=$$GET1^DIQ(52.91,DFN,7,"I")
I 'PSOAINS,'$D(PSOINS(INS)) Q
S INSNAM="Institution Missing" I INS S INSNAM=$$GET1^DIQ(4,INS,.01)
;
;- Get Patient Information (Name,SSN)
D DEM^VADPT S PATNAM=$P(VADM(1),U) S:PATNAM="" PATNAM="Patient Missing"
S PATSSN=$P($P(VADM(2),U,2),"-",3)
S PATNAM=$E(PATNAM,1,22)_"("_PATSSN_")"
;
;Start Loop of PHARMACY PATIENT (#55)
S (SEQ,VARXCNT,TPBRXCNT)=0
F S SEQ=$O(^PS(55,DFN,"P",SEQ)) Q:'SEQ D
. ;Get Prescription Number
. S RXIEN=$G(^PS(55,DFN,"P",SEQ,0)) I $G(^PSRX(RXIEN,0))="" Q
. ;
. ;- Rx not Active
. I '$$ACTIVE^PSOTPCUL(RXIEN) Q
. ;
. ;- VA or TPB prescription
. S TYPE=$S($$GET1^DIQ(52,RXIEN,201,"I"):1,1:0)
. S:TYPE=0 VARXCNT=VARXCNT+1 S:TYPE=1 TPBRXCNT=TPBRXCNT+1
. ;
. S ^TMP("PSOTPB",$J,INSNAM,PATNAM,TYPE,RXIEN)=""
;
;- VA and TPB Active prescritpions must be found
I (VARXCNT'>0)!(TPBRXCNT'>0) K ^TMP("PSOTPB",$J,INSNAM,PATNAM)
Q
;
HDR ; - Prints the Header
N X,DIR S PAG=$G(PAG)+1
I PAG>1,$E(IOST)="C" D Q:$D(DIRUT)
. F Q:$Y>(IOSL-2) W !
. S DIR(0)="E",DIR("A")=" Press ENTER to Continue or ^ to Exit" D ^DIR
;
W @IOF,!,"REPORT OF PATIENTS WITH TPB AND NON-TBP RX's ON FILE",?70,"Page: ",$J(PAG,3)
W !,?48,"Run Date: "_$$FMTE^XLFDT($$NOW^XLFDT())
W:$G(INST)'="" !,"INSTITUTION: ",INS
S X="",$P(X,"-",80)="" W !,X
W !,"PATIENT (LAST4SSN)",?30,"VA RX#",?42,"TPB RX#",?54,"DRUG"
W !,X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOTPRP1 4656 printed Dec 13, 2024@02:36 Page 2
PSOTPRP1 ;BIR/MR - Report of Patients with TPB and Non-TBP Active Rx's ;12/03/03
+1 ;;7.0;OUTPATIENT PHARMACY;**160,227**;DEC 1997
+2 ;
EN ;
+1 ;placed out of order by PSO*7*227
QUIT
+2 NEW OINAM,INS,INSNAM,VADM,TYPE,DRGIEN,TPBRXCNT,SEQ,DFN,RXIEN,RXEXT,RX,POP
+3 NEW PSOPAT,PSOAINS,PATNAM,PATCNT,PAT,PAG,INST,PATSSN,PSOAPT,VARXCNT,Y
+4 ;
+5 WRITE !!,"This report prints entries from the TPB ELIGIBILITY file (#52.91)."
+6 WRITE !,"If multiple Institutions are selected, and some Institutions have data and"
+7 WRITE !,"some don't, only those Institutions that have data will print on the report.",!
+8 ;
+9 ;Ask for Institutions
+10 NEW DIC,X,I
KILL PSOINS
SET PSOAINS=0
+11 WRITE !,?5,"You may select a single or multiple INSTITUTIONS,"
+12 WRITE !,?5,"or enter ^ALL to select all INSTITUTIONS.",!
+13 SET DIC=4
SET DIC(0)="QEAM"
SET DIC("A")=" INSTITUTION: "
+14 FOR
DO ^DIC
if Y<0
QUIT
SET PSOINS(+Y)=""
KILL DIC("B")
+15 IF X="^ALL"
SET PSOAINS=1
KILL PSOINS,DUOUT
GOTO PAT
+16 IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
+17 IF '$DATA(PSOINS)&(Y<0)
GOTO END
+18 ;
PAT ; - Selection of PATIENTS to print on the Report
+1 NEW DIC,X,I
KILL PSOPT
SET PSOAPT=0
+2 WRITE !!,?5,"You may select a single or multiple PATIENTS,"
+3 WRITE !,?5,"or enter ^ALL to select all PATIENTS.",!
+4 SET DIC=2
SET DIC(0)="QEAM"
SET DIC("A")=" PATIENT: "
+5 SET DIC("S")="I $D(^PS(52.91,+Y))"
+6 FOR
DO ^DIC
if Y<0
QUIT
SET PSOPT(+Y)=""
KILL DIC("B")
+7 IF X="^ALL"
SET PSOAPT=1
KILL PSOPT,DUOUT
GOTO DEV
+8 IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
+9 IF '$DATA(PSOPT)&(Y<0)
GOTO END
+10 ;
DEV WRITE !
KILL %ZIS,IOP,POP,ZTSK
SET %ZIS="QM"
DO ^%ZIS
KILL %ZIS
IF POP
GOTO END
+1 IF $DATA(IO("Q"))
Begin DoDot:1
+2 NEW VAR
KILL IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK
SET ZTRTN="RPT^PSOTPRP1"
+3 SET ZTDESC="Report of Patients with TPB and Non-TPB Rx's"
+4 FOR VAR="PSOPT","PSOAPT","PSOINS","PSOAINS"
if $DATA(@VAR)
SET ZTSAVE(VAR)=""
+5 if $DATA(PSOPT)
SET ZTSAVE("PSOPT(")=""
if $DATA(PSOINS)
SET ZTSAVE("PSOINS(")=""
+6 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report is Queued to print !!"
KILL ZTSK
End DoDot:1
GOTO END
+7 ;
+8 GOTO RPT
+9 ;
END KILL ^TMP("PSOTPB",$JOB)
+1 QUIT
+2 ;
RPT ;- Print the Report
+1 ;
SORT ;- Sort the Data by Institution,Patient Name
+1 SET DFN=0
KILL ^TMP("PSOTPB",$JOB)
+2 ;
+3 ;- ALL Patients
+4 IF PSOAPT
Begin DoDot:1
+5 FOR
SET DFN=$ORDER(^PS(52.91,DFN))
if 'DFN
QUIT
DO STMP
End DoDot:1
GOTO PRINT
+6 ;
+7 ;- Selected Patiens
+8 FOR
SET DFN=$ORDER(PSOPT(DFN))
if 'DFN
QUIT
DO STMP
+9 ;
PRINT ;- Read TMP global and Print Report
+1 SET PAG=0
+2 IF '$DATA(^TMP("PSOTPB",$JOB))
Begin DoDot:1
+3 DO HDR
WRITE !!?30,"*** NO DATA TO PRINT ***"
End DoDot:1
GOTO END
+4 ;
+5 SET (INS,PAT,TYPE,RX)=""
+6 FOR
SET INS=$ORDER(^TMP("PSOTPB",$JOB,INS))
if INS=""
QUIT
Begin DoDot:1
+7 DO HDR
IF $DATA(DIRUT)
QUIT
+8 SET (PATCNT,VARXCNT,TPBRXCNT)=0
+9 FOR
SET PAT=$ORDER(^TMP("PSOTPB",$JOB,INS,PAT))
if PAT=""
QUIT
Begin DoDot:2
+10 WRITE !,PAT
+11 FOR
SET TYPE=$ORDER(^TMP("PSOTPB",$JOB,INS,PAT,TYPE))
if TYPE=""
QUIT
Begin DoDot:3
+12 FOR
SET RX=$ORDER(^TMP("PSOTPB",$JOB,INS,PAT,TYPE,RX))
if RX=""
QUIT
Begin DoDot:4
+13 IF $Y>(IOSL-4)
DO HDR
if $DATA(DIRUT)
QUIT
WRITE !,PAT
+14 SET RXEXT=$$GET1^DIQ(52,RX,.01)
SET DRGIEN=$$GET1^DIQ(52,RX,6)
+15 SET OINAM=$$GET1^DIQ(50,DRGIEN,2.1)
if OINAM=""
SET OINAM=$$GET1^DIQ(52,RX,6)
+16 WRITE ?$SELECT(TYPE=0:30,1:42),RXEXT,?54,$EXTRACT(OINAM,1,26),!
+17 if TYPE=0
SET VARXCNT=VARXCNT+1
if TYPE=1
SET TPBRXCNT=TPBRXCNT+1
End DoDot:4
IF $DATA(DIRUT)
QUIT
End DoDot:3
IF $DATA(DIRUT)
QUIT
+18 SET PATCNT=PATCNT+1
End DoDot:2
IF $DATA(DIRUT)
QUIT
+19 IF '$DATA(DIRUT)
Begin DoDot:2
+20 WRITE !,"TOTAL ",INS,": ",PATCNT," Patient(s) ",VARXCNT," VA Prescriptions"
+21 WRITE TPBRXCNT," TPB Prescriptions."
End DoDot:2
End DoDot:1
IF $DATA(DIRUT)
QUIT
+22 QUIT
+23 ;
STMP ;- Set Temporary Global (^TMP)
+1 ;
+2 ;- Check the Patient Instituion
+3 SET INS=$$GET1^DIQ(52.91,DFN,7,"I")
+4 IF 'PSOAINS
IF '$DATA(PSOINS(INS))
QUIT
+5 SET INSNAM="Institution Missing"
IF INS
SET INSNAM=$$GET1^DIQ(4,INS,.01)
+6 ;
+7 ;- Get Patient Information (Name,SSN)
+8 DO DEM^VADPT
SET PATNAM=$PIECE(VADM(1),U)
if PATNAM=""
SET PATNAM="Patient Missing"
+9 SET PATSSN=$PIECE($PIECE(VADM(2),U,2),"-",3)
+10 SET PATNAM=$EXTRACT(PATNAM,1,22)_"("_PATSSN_")"
+11 ;
+12 ;Start Loop of PHARMACY PATIENT (#55)
+13 SET (SEQ,VARXCNT,TPBRXCNT)=0
+14 FOR
SET SEQ=$ORDER(^PS(55,DFN,"P",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+15 ;Get Prescription Number
+16 SET RXIEN=$GET(^PS(55,DFN,"P",SEQ,0))
IF $GET(^PSRX(RXIEN,0))=""
QUIT
+17 ;
+18 ;- Rx not Active
+19 IF '$$ACTIVE^PSOTPCUL(RXIEN)
QUIT
+20 ;
+21 ;- VA or TPB prescription
+22 SET TYPE=$SELECT($$GET1^DIQ(52,RXIEN,201,"I"):1,1:0)
+23 if TYPE=0
SET VARXCNT=VARXCNT+1
if TYPE=1
SET TPBRXCNT=TPBRXCNT+1
+24 ;
+25 SET ^TMP("PSOTPB",$JOB,INSNAM,PATNAM,TYPE,RXIEN)=""
End DoDot:1
+26 ;
+27 ;- VA and TPB Active prescritpions must be found
+28 IF (VARXCNT'>0)!(TPBRXCNT'>0)
KILL ^TMP("PSOTPB",$JOB,INSNAM,PATNAM)
+29 QUIT
+30 ;
HDR ; - Prints the Header
+1 NEW X,DIR
SET PAG=$GET(PAG)+1
+2 IF PAG>1
IF $EXTRACT(IOST)="C"
Begin DoDot:1
+3 FOR
if $Y>(IOSL-2)
QUIT
WRITE !
+4 SET DIR(0)="E"
SET DIR("A")=" Press ENTER to Continue or ^ to Exit"
DO ^DIR
End DoDot:1
if $DATA(DIRUT)
QUIT
+5 ;
+6 WRITE @IOF,!,"REPORT OF PATIENTS WITH TPB AND NON-TBP RX's ON FILE",?70,"Page: ",$JUSTIFY(PAG,3)
+7 WRITE !,?48,"Run Date: "_$$FMTE^XLFDT($$NOW^XLFDT())
+8 if $GET(INST)'=""
WRITE !,"INSTITUTION: ",INS
+9 SET X=""
SET $PIECE(X,"-",80)=""
WRITE !,X
+10 WRITE !,"PATIENT (LAST4SSN)",?30,"VA RX#",?42,"TPB RX#",?54,"DRUG"
+11 WRITE !,X
+12 QUIT
