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 Sep 23, 2025@20:09:12 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
