- 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 Mar 13, 2025@21:40:53 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
