- PSOPOLY ;BHAM ISC/SAB - patients with a minimum amount of rx's within a # of days ;08/23/17 20:40
- ;;7.0;OUTPATIENT PHARMACY;**19,28,132,326,405,441**;DEC 1997;Build 208
- ;External reference ^PS(55 supported by DBIA# 2228
- ;External reference ^PSDRUG( supported by DBIA# 221
- ;External reference ^DPT( supported by DBIA# 10035
- ;External reference ^PS(50.606 supported by DBIA 2174
- ;External reference ^PS(50.7 supported by DBIA 2223
- K ^TMP($J),DIR S PG=0
- S DIR("A")="Number Of Days To Begin Search",DIR("?")="^D HLP^PSOPOLY",DIR(0)="N^1:730:0",DIR("B")=180 D ^DIR G:$D(DIRUT) END S DAYS=Y K DIR
- S DIR("A")="Minimum Number Of Rxs and Active Non-VA Meds",DIR("B")=7,DIR("?")="^D HLP1^PSOPOLY",DIR(0)="N^1:100:0" D ^DIR G:$D(DIRUT) END S RX=Y K DIR
- PAT W !! S DIC("A")="Enter Patient's Name or ^ALL for All Patients: "
- S DIC(0)="QEM" D EN^PSOPATLK S Y=PSOPTLK G:$E(Y,1,2)="^A"!($E(Y,1,2)="^a") ALL G:"^"[$E(Y) END S (PSODFN,DFN)=+Y
- D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN) S ALL=0 D DEV G:$G(QP)!($D(ZTSK)) END
- ENQ D CON,PID^VADPT S DFN=PSODFN I '$O(^PS(55,DFN,"P","A",PSDATE)),'$O(^PS(55,DFN,"NVA",0)) G NRX
- BEG S RXS=0 S:$G(PSDATEX) PSDATE=PSDATEX
- F S PSDATE=$O(^PS(55,DFN,"P","A",PSDATE)) Q:'PSDATE S (P,J)=0 F S J=$O(^PS(55,DFN,"P","A",PSDATE,J)) Q:'J D:$D(^PSRX(J,0))
- .I 134'[$E(+$P($G(^PSRX(J,"STA")),"^")),$P($G(^PSDRUG($P($G(^PSRX(J,0)),"^",6),0)),"^",3)'["S" S RXS=RXS+1,RX(DFN,J)=+$P($G(^PSRX(J,"STA")),"^")
- N NVA F NVA=0:0 S NVA=$O(^PS(55,DFN,"NVA",NVA)) Q:'NVA I '$P(^PS(55,DFN,"NVA",NVA,0),"^",7) S RXS=RXS+1
- I RXS'<RX S P=0 F S P=$O(RX(DFN,P)) Q:'P S RX0=$S($D(^PSRX(P,0)):^(0),1:""),RX2=$S($D(^(2)):^(2),1:""),RX3=$S($D(^(3)):^(3),1:"") D
- .S STA=RX(DFN,P),DRUG=$S($D(^PSDRUG($P(RX0,"^",6),0)):$P(^PSDRUG($P(RX0,"^",6),0),"^"),1:"UNKNOWN"),CLASS=$S($P($G(^PSDRUG($P(RX0,"^",6),0)),"^",2)]"":$P(^(0),"^",2),1:"UNKNOWN")
- A .S STAT="A^N^R^H^N^S^^^^^^E^DC^^DC^DE^H^P^",STATUS=$P(STAT,"^",STA+1)
- .I STATUS="A",$G(^PSRX(P,"PARK")) S STATUS="AP" ;441 PAPI
- .S FILLDATE=9999999-$P(^PSRX(P,2),"^",2)
- .S ^TMP($J,$P(^DPT(DFN,0),"^"),CLASS,DRUG,FILLDATE,P)=$P(^PSRX(P,0),"^",2)_"^"_RXS_"^"_$P(RX3,"^")_"^"_$P(RX0,"^",4)_"^"_STATUS_"^"_VA("BID")_"^"_DFN
- I RXS'<RX,$O(^TMP($J,$P(^DPT(DFN,0),"^"),""))="" S CLASS="NVA",^TMP($J,$P(^DPT(DFN,0),"^"),CLASS)=DFN_"^"_RXS
- S RXS=0 K RX(DFN),CLASS
- I 'ALL,'$D(^TMP($J)) G NRX
- I 'ALL D PRI G:$G(PSOTRUE) END D NVA G END
- Q
- ;
- PRI S PG=0 D HDR S (DFN,ZDFN)="" D
- .F S DFN=$O(^TMP($J,DFN)) Q:DFN="" S (ZCLASS,CLASS)="" D I ALL,$G(CLASS)="" D:'$G(PSOTRUE) NVA K PSOTRUE W ! F I=1:1:132 W "-"
- ..F S CLASS=$O(^TMP($J,DFN,CLASS)) Q:CLASS="" D
- ...I CLASS="NVA" S PSODFN=$P(^TMP($J,DFN,"NVA"),"^"),PSOTRUE=1 D NVA Q
- ...S DRUG="" F S DRUG=$O(^TMP($J,DFN,CLASS,DRUG)) Q:DRUG="" S FILLDATE="" F S FILLDATE=$O(^TMP($J,DFN,CLASS,DRUG,FILLDATE)) Q:'FILLDATE D
- ....F RNX=0:0 S RNX=$O(^TMP($J,DFN,CLASS,DRUG,FILLDATE,RNX)) Q:'RNX S POLY=^(RNX),PSODFN=$P(POLY,"^",7) D
- .....I ($Y+5)>IOSL D HDR
- .....W ! W:ZDFN'=DFN !,DFN_" ("_$P(POLY,"^",6)_")" W:ZDFN'=DFN ?65,$J($P(POLY,"^",2),3),! W:ZCLASS'=CLASS ?2,$E(CLASS,1,16)
- .....W ?22,DRUG,?65,$P(POLY,"^",5) S Y=$P(POLY,"^",3) W ?77 D DT^DIQ S PROV=$P($G(^VA(200,$P(POLY,"^",4),0)),"^") W ?92,$E(PROV,1,25),?121,$P(^PSRX(RNX,0),"^") S ZCLASS=CLASS,ZDFN=DFN
- .....S TOTRX=$G(TOTRX)+1 S:'$D(^TMP($J,"PAT",DFN)) TOTP=$G(TOTP)+1,^TMP($J,"PAT",DFN)=""
- I ALL U IO W !!,"Total Number of Patients: "_TOTP,?40,"Total Number of Rxs: "_TOTRX,?80,"Average Rxs per Patient: "_(TOTRX\TOTP)
- Q
- END W ! D ^%ZISC K QP,^TMP($J),DIR,DTOUT,DUOUT,DIRUT,DIROUT,%DT,ALL,CLASS,DAYS,DFN,DIC,DRUG,EDT,FILLDATE,PSDATEX,G,I,J,P,PSDATE,RX,RXS,RX0,RX2,RX3,SDT,X,Y,POLY,PROV,POP,RNX,Z0,Z1,Z2,ZCLASS,PG,ZDFN,ZTSK,STA,STAT,STATUS D KVA^VADPT
- K PSODFN,PAT,TOTRX,TOTP S:$D(ZTQUEUED) ZTREQ="@"
- Q
- ALL ;print all patients
- W ! S ALL=1,(TOTRX,TOTP)=0 D DEV G:$G(QP)!($D(ZTSK)) END
- ALLP D CON
- F DFN=0:0 S DFN=$O(^PS(55,DFN)) Q:'DFN S ALL=1 D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN) D PID^VADPT,BEG
- I '$D(^TMP($J)) G NRX
- D PRI,END
- Q
- CON ;convert data to date
- S %DT="",X="T-"_DAYS D ^%DT S SDT=Y,(PSDATE,PSDATEX)=SDT-1,X="T" D ^%DT S EDT=Y,RXS=0
- Q
- NRX ;prints no rx message
- D HDR U IO W:'ALL !,$P(^DPT(DFN,0),"^")_" ("_VA("BID")_")" W !?20,">>>> No Active Prescriptions and/or Non-VA Meds found within the Range <<<<" W @IOF G END
- Q
- HLP ;help module
- W !!,$C(7),"Enter numeric value greater than zero.",!,"The value must a whole number, no decimals or fractions.",!!
- Q
- HLP1 W !!,$C(7),"Enter a numeric value greater than zero.",!,"The number seven (7) is the default, no decimals or fractions.",!,"The count will include both Active Prescriptions and Non-VA Medications.",!!
- Q
- DEV K %ZIS,IOP,ZTSK S %ZIS("B")="",PSOION=ION,%ZIS="QM" D ^%ZIS K %ZIS I POP S QP=1,IOP=PSOION D ^%ZIS K IOP,PSOION Q
- I $G(IOM)<132 W $C(7),!!,"Printout Must be 132 Columns.",!! G DEV
- K PSOION I $D(IO("Q")) D K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Report is queued to print !",!
- .S ZTDESC="Poly Pharmacy Report",ZTRTN=$S('ALL:"ENQ^PSOPOLY",1:"ALLP^PSOPOLY") F G="ALL","RX","DAYS","DFN","PG","PSODFN" S:$D(@G) ZTSAVE(G)=""
- Q
- HDR ;report header
- S PG=PG+1 U IO W @IOF,?55,"Poly Pharmacy Report",!?50,$E(SDT,4,5)_"-"_$E(SDT,6,7)_"-"_($E(SDT,1,3)+1700)_" to "_$E(EDT,4,5)_"-"_$E(EDT,6,7)_"-"_($E(EDT,1,3)+1700)
- W !?37," for "_DAYS_" Days for "_RX_" or More Active Prescriptions and/or Non-VA Meds"
- W ?122,"Page "_PG,!,"Patient",?40,"ID#",?62,"Active Rx's",!,?2,"Class",?22,"Drug",?65,"Status",?77,"Last Filled",?92,"Provider",?121,"Rx Number"
- W ! F I=1:1:132 W "-"
- Q
- NVA ;displays non-va meds
- Q:'$O(^PS(55,PSODFN,"NVA",0)) N TITLE
- D ;*405
- .N DFN S DFN=PSODFN
- .D KVA^VADPT
- .D PID^VADPT
- S PSOSTA=">>>Non-VA MEDS (Not dispensed by VA)<<<"
- S STR=($L(PSOSTA)+IOM/2)-$L(PSOSTA),STP=IOM-(STR+$L(PSOSTA)) F I=1:1:STR S TITLE=$G(TITLE)_" "
- S TITLE=TITLE_PSOSTA F I=1:1:STP S TITLE=TITLE_" "
- D:($Y+7)>IOSL HDR W !!,TITLE
- I $G(CLASS)="NVA" W !,DFN_" ("_VA("BID")_")",?40,"Total Non-VA Meds: "_$P(^TMP($J,DFN,CLASS),"^",2)
- F NVAO=0:0 S NVAO=$O(^PS(55,PSODFN,"NVA",NVAO)) Q:'NVAO D
- .Q:$P(^PS(55,PSODFN,"NVA",NVAO,0),"^",7) Q:'$P(^PS(55,PSODFN,"NVA",NVAO,0),"^")
- .S DUPRX0=^PS(55,PSODFN,"NVA",NVAO,0)
- .I ($Y+7)>IOSL D HDR W !!,TITLE,!,$P(^DPT(PSODFN,0),"^")_" ("_VA("BID")_")"
- .S DOI=$S($P(DUPRX0,"^",2):$P(^PSDRUG($P(DUPRX0,"^",2),0),"^"),1:$P(^PS(50.7,$P(DUPRX0,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^"))
- .W !?2,DOI_" "_$P(DUPRX0,"^",3)
- .W !?5,"Schedule: "_$P(DUPRX0,"^",5)
- .W !?5,"Start Date: "_$$FMTE^XLFDT($P(DUPRX0,"^",9)),?45," Documented: "_$$FMTE^XLFDT($P(DUPRX0,"^",10)) ;_" Status: Active"
- K DUPRX0,NVA,STP,STR,PSOSTA,TITLE,DOI
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPOLY 6737 printed Feb 18, 2025@23:59:13 Page 2
- PSOPOLY ;BHAM ISC/SAB - patients with a minimum amount of rx's within a # of days ;08/23/17 20:40
- +1 ;;7.0;OUTPATIENT PHARMACY;**19,28,132,326,405,441**;DEC 1997;Build 208
- +2 ;External reference ^PS(55 supported by DBIA# 2228
- +3 ;External reference ^PSDRUG( supported by DBIA# 221
- +4 ;External reference ^DPT( supported by DBIA# 10035
- +5 ;External reference ^PS(50.606 supported by DBIA 2174
- +6 ;External reference ^PS(50.7 supported by DBIA 2223
- +7 KILL ^TMP($JOB),DIR
- SET PG=0
- +8 SET DIR("A")="Number Of Days To Begin Search"
- SET DIR("?")="^D HLP^PSOPOLY"
- SET DIR(0)="N^1:730:0"
- SET DIR("B")=180
- DO ^DIR
- if $DATA(DIRUT)
- GOTO END
- SET DAYS=Y
- KILL DIR
- +9 SET DIR("A")="Minimum Number Of Rxs and Active Non-VA Meds"
- SET DIR("B")=7
- SET DIR("?")="^D HLP1^PSOPOLY"
- SET DIR(0)="N^1:100:0"
- DO ^DIR
- if $DATA(DIRUT)
- GOTO END
- SET RX=Y
- KILL DIR
- PAT WRITE !!
- SET DIC("A")="Enter Patient's Name or ^ALL for All Patients: "
- +1 SET DIC(0)="QEM"
- DO EN^PSOPATLK
- SET Y=PSOPTLK
- if $EXTRACT(Y,1,2)="^A"!($EXTRACT(Y,1,2)="^a")
- GOTO ALL
- if "^"[$EXTRACT(Y)
- GOTO END
- SET (PSODFN,DFN)=+Y
- +2 if $PIECE($GET(^PS(55,DFN,0)),"^",6)'=2
- DO EN^PSOHLUP(DFN)
- SET ALL=0
- DO DEV
- if $GET(QP)!($DATA(ZTSK))
- GOTO END
- ENQ DO CON
- DO PID^VADPT
- SET DFN=PSODFN
- IF '$ORDER(^PS(55,DFN,"P","A",PSDATE))
- IF '$ORDER(^PS(55,DFN,"NVA",0))
- GOTO NRX
- BEG SET RXS=0
- if $GET(PSDATEX)
- SET PSDATE=PSDATEX
- +1 FOR
- SET PSDATE=$ORDER(^PS(55,DFN,"P","A",PSDATE))
- if 'PSDATE
- QUIT
- SET (P,J)=0
- FOR
- SET J=$ORDER(^PS(55,DFN,"P","A",PSDATE,J))
- if 'J
- QUIT
- if $DATA(^PSRX(J,0))
- Begin DoDot:1
- +2 IF 134'[$EXTRACT(+$PIECE($GET(^PSRX(J,"STA")),"^"))
- IF $PIECE($GET(^PSDRUG($PIECE($GET(^PSRX(J,0)),"^",6),0)),"^",3)'["S"
- SET RXS=RXS+1
- SET RX(DFN,J)=+$PIECE($GET(^PSRX(J,"STA")),"^")
- End DoDot:1
- +3 NEW NVA
- FOR NVA=0:0
- SET NVA=$ORDER(^PS(55,DFN,"NVA",NVA))
- if 'NVA
- QUIT
- IF '$PIECE(^PS(55,DFN,"NVA",NVA,0),"^",7)
- SET RXS=RXS+1
- +4 IF RXS'<RX
- SET P=0
- FOR
- SET P=$ORDER(RX(DFN,P))
- if 'P
- QUIT
- SET RX0=$SELECT($DATA(^PSRX(P,0)):^(0),1:"")
- SET RX2=$SELECT($DATA(^(2)):^(2),1:"")
- SET RX3=$SELECT($DATA(^(3)):^(3),1:"")
- Begin DoDot:1
- +5 SET STA=RX(DFN,P)
- SET DRUG=$SELECT($DATA(^PSDRUG($PIECE(RX0,"^",6),0)):$PIECE(^PSDRUG($PIECE(RX0,"^",6),0),"^"),1:"UNKNOWN")
- SET CLASS=$SELECT($PIECE($GET(^PSDRUG($PIECE(RX0,"^",6),0)),"^",2)]"":$PIECE(^(0),"^",2),1:"UNKNOWN")
- A SET STAT="A^N^R^H^N^S^^^^^^E^DC^^DC^DE^H^P^"
- SET STATUS=$PIECE(STAT,"^",STA+1)
- +1 ;441 PAPI
- IF STATUS="A"
- IF $GET(^PSRX(P,"PARK"))
- SET STATUS="AP"
- +2 SET FILLDATE=9999999-$PIECE(^PSRX(P,2),"^",2)
- +3 SET ^TMP($JOB,$PIECE(^DPT(DFN,0),"^"),CLASS,DRUG,FILLDATE,P)=$PIECE(^PSRX(P,0),"^",2)_"^"_RXS_"^"_$PIECE(RX3,"^")_"^"_$PIECE(RX0,"^",4)_"^"_STATUS_"^"_VA("BID")_"^"_DFN
- End DoDot:1
- +4 IF RXS'<RX
- IF $ORDER(^TMP($JOB,$PIECE(^DPT(DFN,0),"^"),""))=""
- SET CLASS="NVA"
- SET ^TMP($JOB,$PIECE(^DPT(DFN,0),"^"),CLASS)=DFN_"^"_RXS
- +5 SET RXS=0
- KILL RX(DFN),CLASS
- +6 IF 'ALL
- IF '$DATA(^TMP($JOB))
- GOTO NRX
- +7 IF 'ALL
- DO PRI
- if $GET(PSOTRUE)
- GOTO END
- DO NVA
- GOTO END
- +8 QUIT
- +9 ;
- PRI SET PG=0
- DO HDR
- SET (DFN,ZDFN)=""
- Begin DoDot:1
- +1 FOR
- SET DFN=$ORDER(^TMP($JOB,DFN))
- if DFN=""
- QUIT
- SET (ZCLASS,CLASS)=""
- Begin DoDot:2
- +2 FOR
- SET CLASS=$ORDER(^TMP($JOB,DFN,CLASS))
- if CLASS=""
- QUIT
- Begin DoDot:3
- +3 IF CLASS="NVA"
- SET PSODFN=$PIECE(^TMP($JOB,DFN,"NVA"),"^")
- SET PSOTRUE=1
- DO NVA
- QUIT
- +4 SET DRUG=""
- FOR
- SET DRUG=$ORDER(^TMP($JOB,DFN,CLASS,DRUG))
- if DRUG=""
- QUIT
- SET FILLDATE=""
- FOR
- SET FILLDATE=$ORDER(^TMP($JOB,DFN,CLASS,DRUG,FILLDATE))
- if 'FILLDATE
- QUIT
- Begin DoDot:4
- +5 FOR RNX=0:0
- SET RNX=$ORDER(^TMP($JOB,DFN,CLASS,DRUG,FILLDATE,RNX))
- if 'RNX
- QUIT
- SET POLY=^(RNX)
- SET PSODFN=$PIECE(POLY,"^",7)
- Begin DoDot:5
- +6 IF ($Y+5)>IOSL
- DO HDR
- +7 WRITE !
- if ZDFN'=DFN
- WRITE !,DFN_" ("_$PIECE(POLY,"^",6)_")"
- if ZDFN'=DFN
- WRITE ?65,$JUSTIFY($PIECE(POLY,"^",2),3),!
- if ZCLASS'=CLASS
- WRITE ?2,$EXTRACT(CLASS,1,16)
- +8 WRITE ?22,DRUG,?65,$PIECE(POLY,"^",5)
- SET Y=$PIECE(POLY,"^",3)
- WRITE ?77
- DO DT^DIQ
- SET PROV=$PIECE($GET(^VA(200,$PIECE(POLY,"^",4),0)),"^")
- WRITE ?92,$EXTRACT(PROV,1,25),?121,$PIECE(^PSRX(RNX,0),"^")
- SET ZCLASS=CLASS
- SET ZDFN=DFN
- +9 SET TOTRX=$GET(TOTRX)+1
- if '$DATA(^TMP($JOB,"PAT",DFN))
- SET TOTP=$GET(TOTP)+1
- SET ^TMP($JOB,"PAT",DFN)=""
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- IF ALL
- IF $GET(CLASS)=""
- if '$GET(PSOTRUE)
- DO NVA
- KILL PSOTRUE
- WRITE !
- FOR I=1:1:132
- WRITE "-"
- End DoDot:1
- +10 IF ALL
- USE IO
- WRITE !!,"Total Number of Patients: "_TOTP,?40,"Total Number of Rxs: "_TOTRX,?80,"Average Rxs per Patient: "_(TOTRX\TOTP)
- +11 QUIT
- END WRITE !
- DO ^%ZISC
- KILL QP,^TMP($JOB),DIR,DTOUT,DUOUT,DIRUT,DIROUT,%DT,ALL,CLASS,DAYS,DFN,DIC,DRUG,EDT,FILLDATE,PSDATEX,G,I,J,P,PSDATE,RX,RXS,RX0,RX2,RX3,SDT,X,Y,POLY,PROV,POP,RNX,Z0,Z1,Z2,ZCLASS,PG,ZDFN,ZTSK,STA,STAT,STATUS
- DO KVA^VADPT
- +1 KILL PSODFN,PAT,TOTRX,TOTP
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 QUIT
- ALL ;print all patients
- +1 WRITE !
- SET ALL=1
- SET (TOTRX,TOTP)=0
- DO DEV
- if $GET(QP)!($DATA(ZTSK))
- GOTO END
- ALLP DO CON
- +1 FOR DFN=0:0
- SET DFN=$ORDER(^PS(55,DFN))
- if 'DFN
- QUIT
- SET ALL=1
- if $PIECE($GET(^PS(55,DFN,0)),"^",6)'=2
- DO EN^PSOHLUP(DFN)
- DO PID^VADPT
- DO BEG
- +2 IF '$DATA(^TMP($JOB))
- GOTO NRX
- +3 DO PRI
- DO END
- +4 QUIT
- CON ;convert data to date
- +1 SET %DT=""
- SET X="T-"_DAYS
- DO ^%DT
- SET SDT=Y
- SET (PSDATE,PSDATEX)=SDT-1
- SET X="T"
- DO ^%DT
- SET EDT=Y
- SET RXS=0
- +2 QUIT
- NRX ;prints no rx message
- +1 DO HDR
- USE IO
- if 'ALL
- WRITE !,$PIECE(^DPT(DFN,0),"^")_" ("_VA("BID")_")"
- WRITE !?20,">>>> No Active Prescriptions and/or Non-VA Meds found within the Range <<<<"
- WRITE @IOF
- GOTO END
- +2 QUIT
- HLP ;help module
- +1 WRITE !!,$CHAR(7),"Enter numeric value greater than zero.",!,"The value must a whole number, no decimals or fractions.",!!
- +2 QUIT
- HLP1 WRITE !!,$CHAR(7),"Enter a numeric value greater than zero.",!,"The number seven (7) is the default, no decimals or fractions.",!,"The count will include both Active Prescriptions and Non-VA Medications.",!!
- +1 QUIT
- DEV KILL %ZIS,IOP,ZTSK
- SET %ZIS("B")=""
- SET PSOION=ION
- SET %ZIS="QM"
- DO ^%ZIS
- KILL %ZIS
- IF POP
- SET QP=1
- SET IOP=PSOION
- DO ^%ZIS
- KILL IOP,PSOION
- QUIT
- +1 IF $GET(IOM)<132
- WRITE $CHAR(7),!!,"Printout Must be 132 Columns.",!!
- GOTO DEV
- +2 KILL PSOION
- IF $DATA(IO("Q"))
- Begin DoDot:1
- +3 SET ZTDESC="Poly Pharmacy Report"
- SET ZTRTN=$SELECT('ALL:"ENQ^PSOPOLY",1:"ALLP^PSOPOLY")
- FOR G="ALL","RX","DAYS","DFN","PG","PSODFN"
- if $DATA(@G)
- SET ZTSAVE(G)=""
- End DoDot:1
- KILL IO("Q")
- DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !,"Report is queued to print !",!
- +4 QUIT
- HDR ;report header
- +1 SET PG=PG+1
- USE IO
- WRITE @IOF,?55,"Poly Pharmacy Report",!?50,$EXTRACT(SDT,4,5)_"-"_$EXTRACT(SDT,6,7)_"-"_($EXTRACT(SDT,1,3)+1700)_" to "_$EXTRACT(EDT,4,5)_"-"_$EXTRACT(EDT,6,7)_"-"_($EXTRACT(EDT,1,3)+1700)
- +2 WRITE !?37," for "_DAYS_" Days for "_RX_" or More Active Prescriptions and/or Non-VA Meds"
- +3 WRITE ?122,"Page "_PG,!,"Patient",?40,"ID#",?62,"Active Rx's",!,?2,"Class",?22,"Drug",?65,"Status",?77,"Last Filled",?92,"Provider",?121,"Rx Number"
- +4 WRITE !
- FOR I=1:1:132
- WRITE "-"
- +5 QUIT
- NVA ;displays non-va meds
- +1 if '$ORDER(^PS(55,PSODFN,"NVA",0))
- QUIT
- NEW TITLE
- +2 ;*405
- Begin DoDot:1
- +3 NEW DFN
- SET DFN=PSODFN
- +4 DO KVA^VADPT
- +5 DO PID^VADPT
- End DoDot:1
- +6 SET PSOSTA=">>>Non-VA MEDS (Not dispensed by VA)<<<"
- +7 SET STR=($LENGTH(PSOSTA)+IOM/2)-$LENGTH(PSOSTA)
- SET STP=IOM-(STR+$LENGTH(PSOSTA))
- FOR I=1:1:STR
- SET TITLE=$GET(TITLE)_" "
- +8 SET TITLE=TITLE_PSOSTA
- FOR I=1:1:STP
- SET TITLE=TITLE_" "
- +9 if ($Y+7)>IOSL
- DO HDR
- WRITE !!,TITLE
- +10 IF $GET(CLASS)="NVA"
- WRITE !,DFN_" ("_VA("BID")_")",?40,"Total Non-VA Meds: "_$PIECE(^TMP($JOB,DFN,CLASS),"^",2)
- +11 FOR NVAO=0:0
- SET NVAO=$ORDER(^PS(55,PSODFN,"NVA",NVAO))
- if 'NVAO
- QUIT
- Begin DoDot:1
- +12 if $PIECE(^PS(55,PSODFN,"NVA",NVAO,0),"^",7)
- QUIT
- if '$PIECE(^PS(55,PSODFN,"NVA",NVAO,0),"^")
- QUIT
- +13 SET DUPRX0=^PS(55,PSODFN,"NVA",NVAO,0)
- +14 IF ($Y+7)>IOSL
- DO HDR
- WRITE !!,TITLE,!,$PIECE(^DPT(PSODFN,0),"^")_" ("_VA("BID")_")"
- +15 SET DOI=$SELECT($PIECE(DUPRX0,"^",2):$PIECE(^PSDRUG($PIECE(DUPRX0,"^",2),0),"^"),1:$PIECE(^PS(50.7,$PIECE(DUPRX0,"^"),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^(0),"^",2),0),"^"))
- +16 WRITE !?2,DOI_" "_$PIECE(DUPRX0,"^",3)
- +17 WRITE !?5,"Schedule: "_$PIECE(DUPRX0,"^",5)
- +18 ;_" Status: Active"
- WRITE !?5,"Start Date: "_$$FMTE^XLFDT($PIECE(DUPRX0,"^",9)),?45," Documented: "_$$FMTE^XLFDT($PIECE(DUPRX0,"^",10))
- End DoDot:1
- +19 KILL DUPRX0,NVA,STP,STR,PSOSTA,TITLE,DOI
- +20 QUIT
