PSOSDP ;BHAM ISC/SAB - poly pharmacy report attached to action/info profile ;14-May-2010 07:56;PLS
;;7.0;OUTPATIENT PHARMACY;**2,17,19,107,110,155,176,1005,233,258,326,1010**;DEC 1997;Build 62
;called from PSOSD
; Modified - IHS/CIA/PLS - 12/11/03 - Line HD+5 and HD+12
Q:+$G(^TMP($J,DFN))<PSONUM!($G(DOD(DFN))]"") S DRG="",P=0,PSOPOLP=0 D HD K SGY
F S DRG=$O(^TMP($J,DFN,DRG)) Q:DRG="" F S P=$O(^TMP($J,DFN,DRG,P)) Q:'P I $G(^PSRX(P,0))]"" S RX0=^PSRX(P,0),RX2=$G(^(2)),RX3=$G(^(3)) D K SGY
.I $Y+6>IOSL D FT,HD
.S SIG=$P($G(^PSRX(P,"SIG")),"^") W !?10,"* "_$E(DRG,1,40),?52 D SIG W $G(BSIG(1)),?79,"*"
.I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV W !?10,"*",?52,$G(BSIG(PSREV)),?79,"*" I $Y+4>IOSL,$O(BSIG(PSREV)) D FT,HD
.K BSIG,PSREV
D FT K PSOGY
Q
SIG K FSIG,BSIG I $P($G(^PSRX(P,"SIG")),"^",2) D FSIG^PSOUTLA("R",P,26) F PSREV=1:1 Q:'$D(FSIG(PSREV)) S BSIG(PSREV)=FSIG(PSREV)
K FSIG,PSREV I '$P($G(^PSRX(P,"SIG")),"^",2) D EN3^PSOUTLA1(P,26)
Q
HD S FN=DFN
D ELIG^PSOSD1,DEM^VADPT,INP^VADPT,ADD^VADPT,PID^VADPT S PSSN=VA("PID"),ADDRFL=$S(+VAPA(9):"Temporary ",1:"")
S PSNAME=$E(VADM(1),1,28),PSDOB=$P(VADM(3),"^",2)
W @IOF,!,"Polypharmacy Rx Profile Review",?47,"Run Date: " S Y=DT D DT^DIO2 W ?71,"Page: "_PAGE S PAGE=PAGE+1,X=$$SITE^VASITE
;IHS/CIA/PLS - 01/28/04 - Removed references to VAMC
;W !,"Sorted by drug name for Rx's currently active",@$S(PSORM:"?70",1:"!"),"Site: VAMC "_$P(X,"^",2)_"( "_$P(X,"^",3)_")",!,$E(LINE,1,$S('PSORM:80,1:IOM)-1)
W !,"Sorted by drug name for Rx's currently active",@$S(PSORM:"?70",1:"!"),"Site: "_$P(X,"^",2)_"( "_$P(X,"^",3)_")",!,$E(LINE,1,$S('PSORM:80,1:IOM)-1)
I $D(CLINICX) W !?1,"Clinic: ",$E(CLINICX,1,28),?45,"Date/Time: " S Y=CLDT D DT^DIO2
W !?1,"Name : ",PSNAME,?30 W ?58,"Review Date: ________" W !?1,"DOB : "_PSDOB
W:ADDRFL]"" ?30,ADDRFL,! W ?30,"Address :"
I ADDRFL="" D CHECKBAI^PSOSD1
W ?41,VAPA(1) W:VAPA(2)]"" !?41,VAPA(2) W:VAPA(3)]"" !?41,VAPA(3) W !?41,VAPA(4)_", "_$P(VAPA(5),"^",2)_" "_VAPA(6),!?30,"Phone : "_VAPA(8)
S PSOBAR2=PSOBAR0,PSOBAR3=PSOBAR1
S PSOBAR4=$G(PSOBAR3)]""&($G(PSOBAR2)]"")&(+$P($G(PSOPAR),"^"))
I PSOBAR4 S X="S",X2=PSSN W @$S('PSORM:"!?30",1:"?$X+5") S X1=$X W @PSOBAR3,X2,@PSOBAR2,$C(13) S $X=0
; IHS/CIA/PLS - 12/11/03 - Changed to retrieve from PCC Vital
;F GMRVSTR="WT","HT" S VM=GMRVSTR D EN6^GMRVUTL S @VM=X,$P(@VM,"^")=$E($P(@VM,"^"),4,5)_"/"_$E($P(@VM,"^"),6,7)_"/"_($E($P(@VM,"^"),1,3)+1700)
;S X=$P(WT,"^",8),Y=$J(X/2.2,0,2),WT=WT_"^"_Y,X=$P(HT,"^",8),Y=$J(2.54*X,0,2),HT=HT_"^"_Y
S WT=$$VITALF^APSPFUNC(DFN,"WT"),$P(WT,U,9)=$$VITCWT^APSPFUNC($P(WT,U,8))
S HT=$$VITALF^APSPFUNC(DFN,"HT"),$P(HT,U,9)=$$VITCHT^APSPFUNC($P(HT,U,8))
W !?1,"WEIGHT(Kg): " W:+$P(WT,"^",8) $P(WT,"^",9)_" ("_$P(WT,"^")_")" W ?41,"HEIGHT(cm): " W:$P(HT,"^",8) $P(HT,"^",9)_" ("_$P(HT,"^")_")" K VM,WT,HT
W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1),!!!?10 F I=1:1:70 W "*"
W !?10,"*",?35,"POLYPHARMACY REVIEW",?79,"*",!?10,"*",?79,"*",!?10,"* Patient: "_PSNAME,?50,"(ID#: "_VA("BID")_")",?79,"*"
W !?10,"* is identified as having "_PSONUM_" or more active prescriptions",?79,"*",!?10,"* for drugs (excluding supplies). To avoid unnecessary",?79,"*"
W !?10,"* medications, please review these to ensure that each one",?79,"*",!?10,"* is essential. Unnecessary medications may be discontinued on",?79,"*"
W !?10,"* the attached Action Profile.",?79,"*",!?10,"*",?79,"*",!?10,"* I have reviewed the medications below and have taken",?79,"*",!?10,"* actions to discontinue those that are no longer required.",?79,"*"
F I=1:1:3 W !?10,"*",?79,"*"
W !?10,"*",?25 F I=1:1:35 W "_"
W ?79,"*",!?10,"*",?25,"(Signature)",?79,"*" F I=1:1:2 W !?10,"*",?79,"*"
W !?10,"*",?25,"Drugs ("_^TMP($J,DFN)_")",?60,"SIG",?79,"*"
W !?10,"* " F I=1:1:30 W "-"
W ?52 F I=1:1:20 W "-"
W ?79,"*"
Q
FT W !?10 F I=1:1:70 W "*"
Q
CLSG ;clinic group sort and print
S CLSP=1,DIC("A")="Select Clinic Sort Group: "
S DIC="^PS(59.8,",DIC(0)="AEQM" D ^DIC G:"^"[X EXIT^PSOSD G:Y<0 CLSG
S CLSG=+Y
I '$O(^PS(59.8,CLSG,1,0)) W !!,$C(7),"There are no clinics defined for this Clinic Group!",!,$C(7) G CLSG
S %DT="AEFX",%DT("A")="FOR DATE: " D ^%DT G:"^"[X EXIT^PSOSD G CLSG:Y<0 S (APCLDT,CLDT)=Y,$P(LINE,"-",132)="-"
D DAYS^PSOSD1 G:$D(DIRUT) EXIT S X1=DT,X2=-PSDAYS D C^%DTC S PSDATE=X S PSTYPE=$S($D(PSTYPE):PSTYPE,1:0)
K %DT,%ZIS,IOP,ZTSK,ZTQUEUED S PSOION=ION,%ZIS="QM",%ZIS("B")="",%ZIS("A")=$S(PSTYPE:"Select a Printer: ",1:"DEVICE: ")
S %ZIS("S")=$S(PSTYPE:"I $E($G(^%ZIS(2,+$G(^(""SUBTYPE"")),0)),1)=""P""",1:"")
N PSOBARS,PSOBAR0,PSOBAR1
D ^%ZIS I POP S IOP=PSOION K PSOION G EXIT
S APRT=ION ;D ^%ZISC
K DTOUT,DIR,DIRUT
W ! I $G(IO("Q")) D W:$D(ZTSK) !,"Report Queued to Print !!",!! G EXIT
.S %DT="ERXAFS",%DT("A")="Request Start Time: ",%DT("B")="NOW",%DT(0)="NOW" D ^%DT W ! Q:$D(DIRUT)!(X["^") S APTM=Y
.F G="LINE","CLDT","CLSG","PSOPOL","PSOSYS","PSOINST","PSOBAR3","PSOBAR4","PSOBAR2","PSOPAR","PSOPAR7","PRF","PSDAYS","PSDATE","PSTYPE","PSOSITE","PSDATE","PSDAY","PSONUM","PSORM" S:$D(@G) ZTSAVE(G)=""
.S ZTSAVE("APCLDT")="",ZTDTH=APTM,ZTDESC="Clinic Sort Group Action Profile (Outpatient Pharmacy).",ZTSAVE("ZTREQ")="@",ZTSAVE("APRT")="",ZTIO=APRT,ZTRTN="EN^PSOSDP" D ^%ZTLOAD
;
EN ;
S APIFLDS="1;2;3;4;5;6;7;8;9;10;11;12",ALL=1
S CLN=0 ;S PSOIOS=IOS D DEVBAR^PSOBMST
F S CLN=$O(^PS(59.8,CLSG,1,CLN)) Q:'CLN S FR=CLN_","_CLDT,PSOT=CLDT,TO=CLN_","_CLDT_".2359" D CLIN1^PSOSDRAP S CLDT=APCLDT
D ^%ZISC
;
EXIT K ADDRFL,CAN,CLDT,CLINICX,CLSG,CLSP,CNT,CS,DFN,G,PAGE,PCLASS,PRF,PSDATE
K PSDAY,PSDAYS,PSDT,PIIX,PSNAME,PSONUM,PSOT,PSSN,PSTYPE,RF,RFS,RXNO
K RXNODE,PSORM,PSOUT,PSOION,ZTDESC,DQTIME,F,O,W,CLN,APQUE,APTM,APRT
K APCLDT D KVA^VADPT,EXIT^PSOSD
G:'$D(ZTQUEUED) ^PSOSD
Q
;
COS I $P($G(^PSRX(J,3)),"^",3),$D(^VA(200,+$P($G(^(3)),"^",3),0)) W !?99,"COSIGNER: "_$P($G(^VA(200,$P(^PSRX(J,3),"^",3),0)),"^")
Q
PSOSDP ;BHAM ISC/SAB - poly pharmacy report attached to action/info profile ;14-May-2010 07:56;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**2,17,19,107,110,155,176,1005,233,258,326,1010**;DEC 1997;Build 62
+2 ;called from PSOSD
+3 ; Modified - IHS/CIA/PLS - 12/11/03 - Line HD+5 and HD+12
+4 IF +$GET(^TMP($JOB,DFN))<PSONUM!($GET(DOD(DFN))]"")
QUIT
SET DRG=""
SET P=0
SET PSOPOLP=0
DO HD
KILL SGY
+5 FOR
SET DRG=$ORDER(^TMP($JOB,DFN,DRG))
IF DRG=""
QUIT
FOR
SET P=$ORDER(^TMP($JOB,DFN,DRG,P))
IF 'P
QUIT
IF $GET(^PSRX(P,0))]""
SET RX0=^PSRX(P,0)
SET RX2=$GET(^(2))
SET RX3=$GET(^(3))
Begin DoDot:1
+6 IF $Y+6>IOSL
DO FT
DO HD
+7 SET SIG=$PIECE($GET(^PSRX(P,"SIG")),"^")
WRITE !?10,"* "_$EXTRACT(DRG,1,40),?52
DO SIG
WRITE $GET(BSIG(1)),?79,"*"
+8 IF $ORDER(BSIG(1))
FOR PSREV=1:0
SET PSREV=$ORDER(BSIG(PSREV))
IF 'PSREV
QUIT
WRITE !?10,"*",?52,$GET(BSIG(PSREV)),?79,"*"
IF $Y+4>IOSL
IF $ORDER(BSIG(PSREV))
DO FT
DO HD
+9 KILL BSIG,PSREV
End DoDot:1
KILL SGY
+10 DO FT
KILL PSOGY
+11 QUIT
SIG KILL FSIG,BSIG
IF $PIECE($GET(^PSRX(P,"SIG")),"^",2)
DO FSIG^PSOUTLA("R",P,26)
FOR PSREV=1:1
IF '$DATA(FSIG(PSREV))
QUIT
SET BSIG(PSREV)=FSIG(PSREV)
+1 KILL FSIG,PSREV
IF '$PIECE($GET(^PSRX(P,"SIG")),"^",2)
DO EN3^PSOUTLA1(P,26)
+2 QUIT
HD SET FN=DFN
+1 DO ELIG^PSOSD1
DO DEM^VADPT
DO INP^VADPT
DO ADD^VADPT
DO PID^VADPT
SET PSSN=VA("PID")
SET ADDRFL=$SELECT(+VAPA(9):"Temporary ",1:"")
+2 SET PSNAME=$EXTRACT(VADM(1),1,28)
SET PSDOB=$PIECE(VADM(3),"^",2)
+3 WRITE @IOF,!,"Polypharmacy Rx Profile Review",?47,"Run Date: "
SET Y=DT
DO DT^DIO2
WRITE ?71,"Page: "_PAGE
SET PAGE=PAGE+1
SET X=$$SITE^VASITE
+4 ;IHS/CIA/PLS - 01/28/04 - Removed references to VAMC
+5 ;W !,"Sorted by drug name for Rx's currently active",@$S(PSORM:"?70",1:"!"),"Site: VAMC "_$P(X,"^",2)_"( "_$P(X,"^",3)_")",!,$E(LINE,1,$S('PSORM:80,1:IOM)-1)
+6 WRITE !,"Sorted by drug name for Rx's currently active",@$SELECT(PSORM:"?70",1:"!"),"Site: "_$PIECE(X,"^",2)_"( "_$PIECE(X,"^",3)_")",!,$EXTRACT(LINE,1,$SELECT('PSORM:80,1:IOM)-1)
+7 IF $DATA(CLINICX)
WRITE !?1,"Clinic: ",$EXTRACT(CLINICX,1,28),?45,"Date/Time: "
SET Y=CLDT
DO DT^DIO2
+8 WRITE !?1,"Name : ",PSNAME,?30
WRITE ?58,"Review Date: ________"
WRITE !?1,"DOB : "_PSDOB
+9 IF ADDRFL]""
WRITE ?30,ADDRFL,!
WRITE ?30,"Address :"
+10 IF ADDRFL=""
DO CHECKBAI^PSOSD1
+11 WRITE ?41,VAPA(1)
IF VAPA(2)]""
WRITE !?41,VAPA(2)
IF VAPA(3)]""
WRITE !?41,VAPA(3)
WRITE !?41,VAPA(4)_", "_$PIECE(VAPA(5),"^",2)_" "_VAPA(6),!?30,"Phone : "_VAPA(8)
+12 SET PSOBAR2=PSOBAR0
SET PSOBAR3=PSOBAR1
+13 SET PSOBAR4=$GET(PSOBAR3)]""&($GET(PSOBAR2)]"")&(+$PIECE($GET(PSOPAR),"^"))
+14 IF PSOBAR4
SET X="S"
SET X2=PSSN
WRITE @$SELECT('PSORM:"!?30",1:"?$X+5")
SET X1=$X
WRITE @PSOBAR3,X2,@PSOBAR2,$CHAR(13)
SET $X=0
+15 ; IHS/CIA/PLS - 12/11/03 - Changed to retrieve from PCC Vital
+16 ;F GMRVSTR="WT","HT" S VM=GMRVSTR D EN6^GMRVUTL S @VM=X,$P(@VM,"^")=$E($P(@VM,"^"),4,5)_"/"_$E($P(@VM,"^"),6,7)_"/"_($E($P(@VM,"^"),1,3)+1700)
+17 ;S X=$P(WT,"^",8),Y=$J(X/2.2,0,2),WT=WT_"^"_Y,X=$P(HT,"^",8),Y=$J(2.54*X,0,2),HT=HT_"^"_Y
+18 SET WT=$$VITALF^APSPFUNC(DFN,"WT")
SET $PIECE(WT,U,9)=$$VITCWT^APSPFUNC($PIECE(WT,U,8))
+19 SET HT=$$VITALF^APSPFUNC(DFN,"HT")
SET $PIECE(HT,U,9)=$$VITCHT^APSPFUNC($PIECE(HT,U,8))
+20 WRITE !?1,"WEIGHT(Kg): "
IF +$PIECE(WT,"^",8)
WRITE $PIECE(WT,"^",9)_" ("_$PIECE(WT,"^")_")"
WRITE ?41,"HEIGHT(cm): "
IF $PIECE(HT,"^",8)
WRITE $PIECE(HT,"^",9)_" ("_$PIECE(HT,"^")_")"
KILL VM,WT,HT
+21 WRITE !,$EXTRACT(LINE,1,$SELECT('PSORM:80,1:IOM)-1),!!!?10
FOR I=1:1:70
WRITE "*"
+22 WRITE !?10,"*",?35,"POLYPHARMACY REVIEW",?79,"*",!?10,"*",?79,"*",!?10,"* Patient: "_PSNAME,?50,"(ID#: "_VA("BID")_")",?79,"*"
+23 WRITE !?10,"* is identified as having "_PSONUM_" or more active prescriptions",?79,"*",!?10,"* for drugs (excluding supplies). To avoid unnecessary",?79,"*"
+24 WRITE !?10,"* medications, please review these to ensure that each one",?79,"*",!?10,"* is essential. Unnecessary medications may be discontinued on",?79,"*"
+25 WRITE !?10,"* the attached Action Profile.",?79,"*",!?10,"*",?79,"*",!?10,"* I have reviewed the medications below and have taken",?79,"*",!?10,"* actions to discontinue those that are no longer required.",?79,"*"
+26 FOR I=1:1:3
WRITE !?10,"*",?79,"*"
+27 WRITE !?10,"*",?25
FOR I=1:1:35
WRITE "_"
+28 WRITE ?79,"*",!?10,"*",?25,"(Signature)",?79,"*"
FOR I=1:1:2
WRITE !?10,"*",?79,"*"
+29 WRITE !?10,"*",?25,"Drugs ("_^TMP($JOB,DFN)_")",?60,"SIG",?79,"*"
+30 WRITE !?10,"* "
FOR I=1:1:30
WRITE "-"
+31 WRITE ?52
FOR I=1:1:20
WRITE "-"
+32 WRITE ?79,"*"
+33 QUIT
FT WRITE !?10
FOR I=1:1:70
WRITE "*"
+1 QUIT
CLSG ;clinic group sort and print
+1 SET CLSP=1
SET DIC("A")="Select Clinic Sort Group: "
+2 SET DIC="^PS(59.8,"
SET DIC(0)="AEQM"
DO ^DIC
IF "^"[X
GOTO EXIT^PSOSD
IF Y<0
GOTO CLSG
+3 SET CLSG=+Y
+4 IF '$ORDER(^PS(59.8,CLSG,1,0))
WRITE !!,$CHAR(7),"There are no clinics defined for this Clinic Group!",!,$CHAR(7)
GOTO CLSG
+5 SET %DT="AEFX"
SET %DT("A")="FOR DATE: "
DO ^%DT
IF "^"[X
GOTO EXIT^PSOSD
IF Y<0
GOTO CLSG
SET (APCLDT,CLDT)=Y
SET $PIECE(LINE,"-",132)="-"
+6 DO DAYS^PSOSD1
IF $DATA(DIRUT)
GOTO EXIT
SET X1=DT
SET X2=-PSDAYS
DO C^%DTC
SET PSDATE=X
SET PSTYPE=$SELECT($DATA(PSTYPE):PSTYPE,1:0)
+7 KILL %DT,%ZIS,IOP,ZTSK,ZTQUEUED
SET PSOION=ION
SET %ZIS="QM"
SET %ZIS("B")=""
SET %ZIS("A")=$SELECT(PSTYPE:"Select a Printer: ",1:"DEVICE: ")
+8 SET %ZIS("S")=$SELECT(PSTYPE:"I $E($G(^%ZIS(2,+$G(^(""SUBTYPE"")),0)),1)=""P""",1:"")
+9 NEW PSOBARS,PSOBAR0,PSOBAR1
+10 DO ^%ZIS
IF POP
SET IOP=PSOION
KILL PSOION
GOTO EXIT
+11 ;D ^%ZISC
SET APRT=ION
+12 KILL DTOUT,DIR,DIRUT
+13 WRITE !
IF $GET(IO("Q"))
Begin DoDot:1
+14 SET %DT="ERXAFS"
SET %DT("A")="Request Start Time: "
SET %DT("B")="NOW"
SET %DT(0)="NOW"
DO ^%DT
WRITE !
IF $DATA(DIRUT)!(X["^")
QUIT
SET APTM=Y
+15 FOR G="LINE","CLDT","CLSG","PSOPOL","PSOSYS","PSOINST","PSOBAR3","PSOBAR4","PSOBAR2","PSOPAR","PSOPAR7","PRF","PSDAYS","PSDATE","PSTYPE","PSOSITE","PSDATE","PSDAY","PSONUM","PSORM"
IF $DATA(@G)
SET ZTSAVE(G)=""
+16 SET ZTSAVE("APCLDT")=""
SET ZTDTH=APTM
SET ZTDESC="Clinic Sort Group Action Profile (Outpatient Pharmacy)."
SET ZTSAVE("ZTREQ")="@"
SET ZTSAVE("APRT")=""
SET ZTIO=APRT
SET ZTRTN="EN^PSOSDP"
DO ^%ZTLOAD
End DoDot:1
IF $DATA(ZTSK)
WRITE !,"Report Queued to Print !!",!!
GOTO EXIT
+17 ;
EN ;
+1 SET APIFLDS="1;2;3;4;5;6;7;8;9;10;11;12"
SET ALL=1
+2 ;S PSOIOS=IOS D DEVBAR^PSOBMST
SET CLN=0
+3 FOR
SET CLN=$ORDER(^PS(59.8,CLSG,1,CLN))
IF 'CLN
QUIT
SET FR=CLN_","_CLDT
SET PSOT=CLDT
SET TO=CLN_","_CLDT_".2359"
DO CLIN1^PSOSDRAP
SET CLDT=APCLDT
+4 DO ^%ZISC
+5 ;
EXIT KILL ADDRFL,CAN,CLDT,CLINICX,CLSG,CLSP,CNT,CS,DFN,G,PAGE,PCLASS,PRF,PSDATE
+1 KILL PSDAY,PSDAYS,PSDT,PIIX,PSNAME,PSONUM,PSOT,PSSN,PSTYPE,RF,RFS,RXNO
+2 KILL RXNODE,PSORM,PSOUT,PSOION,ZTDESC,DQTIME,F,O,W,CLN,APQUE,APTM,APRT
+3 KILL APCLDT
DO KVA^VADPT
DO EXIT^PSOSD
+4 IF '$DATA(ZTQUEUED)
GOTO ^PSOSD
+5 QUIT
+6 ;
COS IF $PIECE($GET(^PSRX(J,3)),"^",3)
IF $DATA(^VA(200,+$PIECE($GET(^(3)),"^",3),0))
WRITE !?99,"COSIGNER: "_$PIECE($GET(^VA(200,$PIECE(^PSRX(J,3),"^",3),0)),"^")
+1 QUIT
