PSOP ;BIR/SAB - Medication profile long or short ;May 20, 2020@10:37:43
;;7.0;OUTPATIENT PHARMACY;**2,15,98,132,148,326,313,441**;DEC 1997;Build 208
;External reference to PS(55 supported by DBIA 2228
;External reference to PS(59.7 supported by DBIA 694
;External reference to PSDRUG supported by DBIA 221
W !! K ^TMP($J),ZTSK,CLS S DIC(0)="QEAM" D EN^PSOPATLK S Y=PSOPTLK G Q:+Y<1 S PSOLOUD=1,DFN=+Y D:$P($G(^PS(55,+Y,0)),"^",6)'=2 EN^PSOHLUP(+Y) K PSOLOUD S Y=DFN
DOIT S (FN,DFN,D0,DA)=+Y I '$D(^PS(55,+Y,"P")),'$D(^("ARC")),'$D(^("NVA")),'$D(^PS(52.41,"AOR",+Y)) W !?20,$C(7),"NO PHARMACY INFORMATION" H 5 D ^PSODEM G PSOP
I '$O(^PS(55,+Y,"P",0)),$D(^PS(55,+Y,"ARC")) D ^PSODEM W !!,"PATIENT HAS ARCHIVED PRESCRIPTIONS",! G PSOP
S DIR("?")="Enter 'L' for a long profile or 'S' for a short profile",DIR("A")="LONG or SHORT: ",DIR(0)="SA^L:LONG;S:SHORT",DIR("B")="SHORT" D ^DIR G:$D(DUOUT)!$D(DIRUT) Q S PLS=Y K DIR
S S DIR(0)="SA^D:DATE;M:MEDICATION;C:CLASS",DIR("A")="Sort by DATE, CLASS or MEDICATION: ",DIR("B")=$S($P($G(PSOPAR),"^",14)=2:"MEDICATION",$P($G(PSOPAR),"^",14)=1:"CLASS",1:"DATE")
S DIR("?",1)="Enter 'DATE', 'CLASS' or 'MEDICATION' to determine the order in which",DIR("?")="prescriptions will appear on the profile." D ^DIR G:$D(DUOUT)!$D(DIRUT) Q S PSRT=$S(Y="D":"DATE",Y="M":"DRUG",1:"CLSS")
S HDR=$S(Y="D":"ISSUE DATE",Y="M":"DRUG NAME",1:"DRUG CLASS") K DIR
K DIR G:PSRT="DATE" DEV S DIR("A")="Profile Expiration/Discontinued cutoff",DIR("B")=120,DIR(0)="N^1:9999:0",DIR("?",1)="Enter the number of days which will cut discontinued and expired Rx's from",DIR("?")="the profile."
D ^DIR G:$D(DTOUT)!($D(DUOUT)) Q K DIR S X1=DT,X2=-X D C^%DTC S PSODTCT=X
DEV D SORT^PSOP1 G:$D(DUOUT)!($D(DTOUT)) Q
K %ZIS,IOP,POP,ZTSK S PSOION=ION,%ZIS="MQ" D ^%ZIS K %ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G Q
K PSOION I $D(IO("Q")) S ZTDESC="Patient Medication Profile",ZTRTN="P^PSOP" D G PSOP
.F G="HDR","TO","FR","SDT","PSFR","PSTO","DTS","CLS","EDT","DRS","PSODTCT","FN","DFN","DA","D0","PLS","PSRT","PSOPAR" S:$D(@G) ZTSAVE(G)=""
.K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Task Queued to Print",! K Q,ZTSK D Q
D P,Q G PSOP
P U IO S PAGE=1,$P(PSOPLINE,"-",80)="" K ^TMP($J) D LOOP D ^PSODEM W:$O(^PS(55,DA,"ARC",0)) !!,"Patient Has Archived Prescriptions",!
I $Y+10>IOSL,$E(IOST)="C" D DIR^PSOP1 Q:$D(PQT) W @IOF
W:$P($G(^PS(59.7,1,40.1)),"^") !,"Outpatient prescriptions are discontinued 72 hours after admission"
W !!?(80-$L("Medication Profile Sorted by "_HDR))/2,"Medication Profile Sorted by "_HDR W:$G(FR)]"" !?(80-$L(FR_" to "_TO))/2,FR_" to "_TO
I PLS="S" D ^PSOP1 G Q
W ! S DRUG="" F II=0:0 S DRUG=$O(^TMP($J,DRUG)) Q:DRUG=""!($D(PQT)) F J=0:0 S J=$O(^TMP($J,DRUG,J)) Q:'J D O W:$G(PQT) @IOF Q:$G(PQT) I $Y+8>IOSL,$E(IOST)="C" D DIR^PSOP1 W @IOF Q:$D(PQT)
D PEND^PSOP2,NVA^PSOP2
Q D ^%ZISC K CP,HDR,X1,X2,RX3,^TMP($J),ST0,PSODTCT,ST,D0,DIC,DIR,DIRUT,DUOUT,G,II,K,RXD,RXF,ZX,DRUG,X,DFN,PHYS,PSRT,CT,AL,I1,PLS,REF,LMI,PI,FN,Y,I,J,RX,DRX,ST,RX0,RX1,RX2,DA,PSOPLINE,PAGE,PRLBL,PSOPATOK,PSOPTLK
K PSOLR,PSDIV,PQT,TO,FR,CLS,DRG,DRS,DTS,DTOUT,PSFR,PSTO,SDT,EDT,PPP,FSIG,IIII,STAT,PP,EEEE,PPPCNT,PENDREX,PSOPEND,PPDIS,PPOI,PCOUNT,PPCOUNT,PPP,PSOX S:$D(ZTQUEUED) ZTREQ="@" Q
;
O S RX0=^PSRX(J,0),RX2=$G(^(2)),RX3=$G(^(3)),$P(RX0,"^",15)=$G(^("STA")),DRX="NOT ON FILE",CP=$S(+$G(^PSRX(J,"IB")):"$",1:" ") S:$P(RX0,"^",15)="" $P(RX0,"^",15)=-1
;
I $D(^PSDRUG(+$P(RX0,"^",6),0)) S DRX=$P(^(0),"^")
I $Y+10>IOSL,IOSL["C-" D DIR^PSOP1 W @IOF Q:$D(PQT)
I $Y+10>IOSL,$E(IOST)'="C" S PAGE=PAGE+1 D
.W @IOF,!,$P(^DPT(DFN,0),"^"),?70,"Page: "_PAGE
.W !?(80-$L("Medication Profile Sorted by "_HDR))/2,"Medication Profile Sorted by "_HDR W:$G(FR)]"" !?(80-$L(FR_" to "_TO))/2,FR_" to "_TO
.W !,PSOPLINE
W !!,"Rx #: "_CP_$P(RX0,"^"),$$ECME^PSOBPSUT(J),$$TITRX^PSOUTL(J),?32,"Drug: ",$G(DRX)
S PSOBRSIG=$P($G(^PSRX(J,"SIG")),"^",2) K FSIG,BSIG D
.I PSOBRSIG D FSIG^PSOUTLA("R",J,70) Q
.D EN2^PSOUTLA1(J,70) F IIII=0:0 S IIII=$O(BSIG(IIII)) Q:'IIII S FSIG(IIII)=BSIG(IIII)
K PSOBRSIG,IIII,BSIG
W !?2,"SIG: "_$G(FSIG(1)) D:$O(FSIG(1))
.F IIII=1:0 S IIII=$O(FSIG(IIII)) Q:'IIII!($G(PQT)) W !?7,$G(FSIG(IIII)) D:($Y+5>IOSL)&($E(IOST)["C") DIR^PSOP1 Q:$G(PQT) D:$Y+5>IOSL
..S PAGE=PAGE+1
..W @IOF,!,$P(^DPT(DFN,0),"^"),?70,"Page: "_PAGE
..W !?(80-$L("Medication Profile Sorted by "_HDR))/2,"Medication Profile Sorted by "_HDR W:$G(FR)]"" !?(80-$L(FR_" to "_TO))/2,FR_" to "_TO
..W !,PSOPLINE
W:$P($G(^PSRX(J,"IND")),"^")]"" !,?2,"Indication: "_$P(^PSRX(J,"IND"),"^") ;*441-IND
Q:$G(PQT)
W !?2,"QTY: ",$P(RX0,"^",7),?23,"# of Refills: ",$P(RX0,"^",9),?45,"Issue/Expr: " S Y=$P(RX0,"^",13) W $E(Y,4,5),"-",$E(Y,6,7),"-",$E(Y,2,3),"/" S Y=$P(RX2,"^",6) W:Y $E(Y,4,5),"-",$E(Y,6,7),"-",$E(Y,2,3)
K DIC,X,Y S DIC="^VA(200,",DIC(0)="M",X="`"_+$P(RX0,"^",4) D ^DIC S PHYS=$S(+Y:$P(Y,"^",2),1:"Unknown") K DIC,X,Y
W !?2,"Prov: "_PHYS,?30,"Entry By: "_$P(RX0,"^",16),?45,"Filled: " S Y=$P(RX2,"^",2) W:Y $E(Y,4,5),"-",$E(Y,6,7),"-",$E(Y,2,3) W " (",$P(RX0,"^",11),")"
I $P(RX3,"^",3) D
.K DIC,X,Y S DIC="^VA(200,",DIC(0)="M",X="`"_+$P(RX3,"^",3) D ^DIC S PHYS=$S(+Y:$P(Y,"^",2),1:"Unknown") K DIC,X,Y W !?2,"Cosigner: "_PHYS K PHYS
S PSOLR=$S($P(RX2,"^",13):$P(RX2,"^",13),1:"") F PSOX=0:0 S PSOX=$O(^PSRX(J,1,PSOX)) Q:'PSOX S:$P(^PSRX(J,1,PSOX,0),"^",18) PSOLR=$P(^(0),"^",18)
W !?2,"Last Released: " W:PSOLR $E(PSOLR,4,5)_"-"_$E(PSOLR,6,7)_"-"_$E(PSOLR,2,3)
W ?45,$S($P(RX2,"^",15):"Original Fill Returned to Stock",1:"Original Release: "_$S($P(RX2,"^",13):$E($P(RX2,"^",13),4,5)_"-"_$E($P(RX2,"^",13),6,7)_"-"_$E($P(RX2,"^",13),2,3),1:""))
S CT=0,REF=$P(RX0,"^",9) F K=0:0 S K=$O(^PSRX(J,1,K)) Q:'K S RX1=^PSRX(J,1,K,0) D
.I $Y+5>IOSL,IOSL["C-" D DIR^PSOP1 W @IOF Q:$D(PQT)
.I $Y+5>IOSL,$E(IOST)'="C" S PAGE=PAGE+1 D
..W @IOF,!,$P(^DPT(DFN,0),"^"),?70,"Page: "_PAGE
..W !?(80-$L("Medication Profile Sorted by "_HDR))/2,"Medication Profile Sorted by "_HDR W:$G(FR)]"" !?(80-$L(FR_" to "_TO))/2,FR_" to "_TO
..W !,PSOPLINE
.W !?2,"Refilled: "_$E($P(RX1,"^"),4,5)_"-"_$E($P(RX1,"^"),6,7)_"-"_$E($P(RX1,"^"),2,3)_" ("_$P(RX1,"^",2)_")"_$S($P(RX1,"^",16):"(R)",1:"")
.W ?30,"Released: "_$S($P(RX1,"^",18):$E($P(RX1,"^",18),4,5)_"-"_$E($P(RX1,"^",18),6,7)_"-"_$E($P(RX1,"^",18),2,3),1:"")
.S REF=REF-1
I $Y+2>IOSL,IOSL["C-" D DIR^PSOP1 W @IOF Q:$D(PQT)
I $Y+2>IOSL,$E(IOST)'="C" S PAGE=PAGE+1 W @IOF,!,$P(^DPT(DFN,0),"^"),?70,"Page: "_PAGE
I $O(^PSRX(J,"P",0)) W !?2,"Partials: " F K=0:0 S K=$O(^PSRX(J,"P",K)) Q:'K W $E(^(K,0),4,5),"-",$E(^(0),6,7),"-",$E(^(0),2,3)," (",$P(^(0),"^",2),") QTY:",$P(^(0),"^",4)_$S($P(^(0),"^",16):" (R)",1:"")_", "
W:$P(RX3,"^",7)]"" !?2,"Remarks: ",$P(RX3,"^",7) D STAT^PSOFUNC
S PSDIV=$S($D(^PS(59,+$P(RX2,"^",9),0)):$P(^(0),"^")_" ("_$P(^(0),"^",6)_")",1:"Unknown")
W !?2,"Division: "_$E(PSDIV,1,25),?40,ST,?60,REF," Refill"_$S(REF'=1:"s",1:"")," Left"
Q
LOOP F I=0:0 S I=$O(^PS(55,DFN,"P",I)) Q:'I S J=+^(I,0) D I $G(PSOPATOK),$D(^PSRX(J,0)),$P($G(^PSRX(J,"STA")),"^")'=13 S PRLBL=PSRT_"^PSOP2" D @PRLBL
.S PSOPATOK=1 I $P($G(^PSRX(+$G(J),0)),"^",2),DFN'=$P($G(^(0)),"^",2) K ^PS(55,DFN,"P",I,0) S:$P($G(^PS(55,DFN,"P",0)),"^",4) $P(^PS(55,DFN,"P",0),"^",4)=$P($G(^(0)),"^",4)-1 S PSOPATOK=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOP 7273 printed Apr 09, 2024@21:33:42 Page 2
PSOP ;BIR/SAB - Medication profile long or short ;May 20, 2020@10:37:43
+1 ;;7.0;OUTPATIENT PHARMACY;**2,15,98,132,148,326,313,441**;DEC 1997;Build 208
+2 ;External reference to PS(55 supported by DBIA 2228
+3 ;External reference to PS(59.7 supported by DBIA 694
+4 ;External reference to PSDRUG supported by DBIA 221
+5 WRITE !!
KILL ^TMP($JOB),ZTSK,CLS
SET DIC(0)="QEAM"
DO EN^PSOPATLK
SET Y=PSOPTLK
if +Y<1
GOTO Q
SET PSOLOUD=1
SET DFN=+Y
if $PIECE($GET(^PS(55,+Y,0)),"^",6)'=2
DO EN^PSOHLUP(+Y)
KILL PSOLOUD
SET Y=DFN
DOIT SET (FN,DFN,D0,DA)=+Y
IF '$DATA(^PS(55,+Y,"P"))
IF '$DATA(^("ARC"))
IF '$DATA(^("NVA"))
IF '$DATA(^PS(52.41,"AOR",+Y))
WRITE !?20,$CHAR(7),"NO PHARMACY INFORMATION"
HANG 5
DO ^PSODEM
GOTO PSOP
+1 IF '$ORDER(^PS(55,+Y,"P",0))
IF $DATA(^PS(55,+Y,"ARC"))
DO ^PSODEM
WRITE !!,"PATIENT HAS ARCHIVED PRESCRIPTIONS",!
GOTO PSOP
+2 SET DIR("?")="Enter 'L' for a long profile or 'S' for a short profile"
SET DIR("A")="LONG or SHORT: "
SET DIR(0)="SA^L:LONG;S:SHORT"
SET DIR("B")="SHORT"
DO ^DIR
if $DATA(DUOUT)!$DATA(DIRUT)
GOTO Q
SET PLS=Y
KILL DIR
S SET DIR(0)="SA^D:DATE;M:MEDICATION;C:CLASS"
SET DIR("A")="Sort by DATE, CLASS or MEDICATION: "
SET DIR("B")=$SELECT($PIECE($GET(PSOPAR),"^",14)=2:"MEDICATION",$PIECE($GET(PSOPAR),"^",14)=1:"CLASS",1:"DATE")
+1 SET DIR("?",1)="Enter 'DATE', 'CLASS' or 'MEDICATION' to determine the order in which"
SET DIR("?")="prescriptions will appear on the profile."
DO ^DIR
if $DATA(DUOUT)!$DATA(DIRUT)
GOTO Q
SET PSRT=$SELECT(Y="D":"DATE",Y="M":"DRUG",1:"CLSS")
+2 SET HDR=$SELECT(Y="D":"ISSUE DATE",Y="M":"DRUG NAME",1:"DRUG CLASS")
KILL DIR
+3 KILL DIR
if PSRT="DATE"
GOTO DEV
SET DIR("A")="Profile Expiration/Discontinued cutoff"
SET DIR("B")=120
SET DIR(0)="N^1:9999:0"
SET DIR("?",1)="Enter the number of days which will cut discontinued and expired Rx's from"
SET DIR("?")="the profile."
+4 DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO Q
KILL DIR
SET X1=DT
SET X2=-X
DO C^%DTC
SET PSODTCT=X
DEV DO SORT^PSOP1
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO Q
+1 KILL %ZIS,IOP,POP,ZTSK
SET PSOION=ION
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS
IF POP
SET IOP=PSOION
DO ^%ZIS
KILL IOP,PSOION
GOTO Q
+2 KILL PSOION
IF $DATA(IO("Q"))
SET ZTDESC="Patient Medication Profile"
SET ZTRTN="P^PSOP"
Begin DoDot:1
+3 FOR G="HDR","TO","FR","SDT","PSFR","PSTO","DTS","CLS","EDT","DRS","PSODTCT","FN","DFN","DA","D0","PLS","PSRT","PSOPAR"
if $DATA(@G)
SET ZTSAVE(G)=""
+4 KILL IO("Q")
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Task Queued to Print",!
KILL Q,ZTSK
DO Q
End DoDot:1
GOTO PSOP
+5 DO P
DO Q
GOTO PSOP
P USE IO
SET PAGE=1
SET $PIECE(PSOPLINE,"-",80)=""
KILL ^TMP($JOB)
DO LOOP
DO ^PSODEM
if $ORDER(^PS(55,DA,"ARC",0))
WRITE !!,"Patient Has Archived Prescriptions",!
+1 IF $Y+10>IOSL
IF $EXTRACT(IOST)="C"
DO DIR^PSOP1
if $DATA(PQT)
QUIT
WRITE @IOF
+2 if $PIECE($GET(^PS(59.7,1,40.1)),"^")
WRITE !,"Outpatient prescriptions are discontinued 72 hours after admission"
+3 WRITE !!?(80-$LENGTH("Medication Profile Sorted by "_HDR))/2,"Medication Profile Sorted by "_HDR
if $GET(FR)]""
WRITE !?(80-$LENGTH(FR_" to "_TO))/2,FR_" to "_TO
+4 IF PLS="S"
DO ^PSOP1
GOTO Q
+5 WRITE !
SET DRUG=""
FOR II=0:0
SET DRUG=$ORDER(^TMP($JOB,DRUG))
if DRUG=""!($DATA(PQT))
QUIT
FOR J=0:0
SET J=$ORDER(^TMP($JOB,DRUG,J))
if 'J
QUIT
DO O
if $GET(PQT)
WRITE @IOF
if $GET(PQT)
QUIT
IF $Y+8>IOSL
IF $EXTRACT(IOST)="C"
DO DIR^PSOP1
WRITE @IOF
if $DATA(PQT)
QUIT
+6 DO PEND^PSOP2
DO NVA^PSOP2
Q DO ^%ZISC
KILL CP,HDR,X1,X2,RX3,^TMP($JOB),ST0,PSODTCT,ST,D0,DIC,DIR,DIRUT,DUOUT,G,II,K,RXD,RXF,ZX,DRUG,X,DFN,PHYS,PSRT,CT,AL,I1,PLS,REF,LMI,PI,FN,Y,I,J,RX,DRX,ST,RX0,RX1,RX2,DA,PSOPLINE,PAGE,PRLBL,PSOPATOK,PSOPTLK
+1 KILL PSOLR,PSDIV,PQT,TO,FR,CLS,DRG,DRS,DTS,DTOUT,PSFR,PSTO,SDT,EDT,PPP,FSIG,IIII,STAT,PP,EEEE,PPPCNT,PENDREX,PSOPEND,PPDIS,PPOI,PCOUNT,PPCOUNT,PPP,PSOX
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+2 ;
O SET RX0=^PSRX(J,0)
SET RX2=$GET(^(2))
SET RX3=$GET(^(3))
SET $PIECE(RX0,"^",15)=$GET(^("STA"))
SET DRX="NOT ON FILE"
SET CP=$SELECT(+$GET(^PSRX(J,"IB")):"$",1:" ")
if $PIECE(RX0,"^",15)=""
SET $PIECE(RX0,"^",15)=-1
+1 ;
+2 IF $DATA(^PSDRUG(+$PIECE(RX0,"^",6),0))
SET DRX=$PIECE(^(0),"^")
+3 IF $Y+10>IOSL
IF IOSL["C-"
DO DIR^PSOP1
WRITE @IOF
if $DATA(PQT)
QUIT
+4 IF $Y+10>IOSL
IF $EXTRACT(IOST)'="C"
SET PAGE=PAGE+1
Begin DoDot:1
+5 WRITE @IOF,!,$PIECE(^DPT(DFN,0),"^"),?70,"Page: "_PAGE
+6 WRITE !?(80-$LENGTH("Medication Profile Sorted by "_HDR))/2,"Medication Profile Sorted by "_HDR
if $GET(FR)]""
WRITE !?(80-$LENGTH(FR_" to "_TO))/2,FR_" to "_TO
+7 WRITE !,PSOPLINE
End DoDot:1
+8 WRITE !!,"Rx #: "_CP_$PIECE(RX0,"^"),$$ECME^PSOBPSUT(J),$$TITRX^PSOUTL(J),?32,"Drug: ",$GET(DRX)
+9 SET PSOBRSIG=$PIECE($GET(^PSRX(J,"SIG")),"^",2)
KILL FSIG,BSIG
Begin DoDot:1
+10 IF PSOBRSIG
DO FSIG^PSOUTLA("R",J,70)
QUIT
+11 DO EN2^PSOUTLA1(J,70)
FOR IIII=0:0
SET IIII=$ORDER(BSIG(IIII))
if 'IIII
QUIT
SET FSIG(IIII)=BSIG(IIII)
End DoDot:1
+12 KILL PSOBRSIG,IIII,BSIG
+13 WRITE !?2,"SIG: "_$GET(FSIG(1))
if $ORDER(FSIG(1))
Begin DoDot:1
+14 FOR IIII=1:0
SET IIII=$ORDER(FSIG(IIII))
if 'IIII!($GET(PQT))
QUIT
WRITE !?7,$GET(FSIG(IIII))
if ($Y+5>IOSL)&($EXTRACT(IOST)["C")
DO DIR^PSOP1
if $GET(PQT)
QUIT
if $Y+5>IOSL
Begin DoDot:2
+15 SET PAGE=PAGE+1
+16 WRITE @IOF,!,$PIECE(^DPT(DFN,0),"^"),?70,"Page: "_PAGE
+17 WRITE !?(80-$LENGTH("Medication Profile Sorted by "_HDR))/2,"Medication Profile Sorted by "_HDR
if $GET(FR)]""
WRITE !?(80-$LENGTH(FR_" to "_TO))/2,FR_" to "_TO
+18 WRITE !,PSOPLINE
End DoDot:2
End DoDot:1
+19 ;*441-IND
if $PIECE($GET(^PSRX(J,"IND")),"^")]""
WRITE !,?2,"Indication: "_$PIECE(^PSRX(J,"IND"),"^")
+20 if $GET(PQT)
QUIT
+21 WRITE !?2,"QTY: ",$PIECE(RX0,"^",7),?23,"# of Refills: ",$PIECE(RX0,"^",9),?45,"Issue/Expr: "
SET Y=$PIECE(RX0,"^",13)
WRITE $EXTRACT(Y,4,5),"-",$EXTRACT(Y,6,7),"-",$EXTRACT(Y,2,3),"/"
SET Y=$PIECE(RX2,"^",6)
if Y
WRITE $EXTRACT(Y,4,5),"-",$EXTRACT(Y,6,7),"-",$EXTRACT(Y,2,3)
+22 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="M"
SET X="`"_+$PIECE(RX0,"^",4)
DO ^DIC
SET PHYS=$SELECT(+Y:$PIECE(Y,"^",2),1:"Unknown")
KILL DIC,X,Y
+23 WRITE !?2,"Prov: "_PHYS,?30,"Entry By: "_$PIECE(RX0,"^",16),?45,"Filled: "
SET Y=$PIECE(RX2,"^",2)
if Y
WRITE $EXTRACT(Y,4,5),"-",$EXTRACT(Y,6,7),"-",$EXTRACT(Y,2,3)
WRITE " (",$PIECE(RX0,"^",11),")"
+24 IF $PIECE(RX3,"^",3)
Begin DoDot:1
+25 KILL DIC,X,Y
SET DIC="^VA(200,"
SET DIC(0)="M"
SET X="`"_+$PIECE(RX3,"^",3)
DO ^DIC
SET PHYS=$SELECT(+Y:$PIECE(Y,"^",2),1:"Unknown")
KILL DIC,X,Y
WRITE !?2,"Cosigner: "_PHYS
KILL PHYS
End DoDot:1
+26 SET PSOLR=$SELECT($PIECE(RX2,"^",13):$PIECE(RX2,"^",13),1:"")
FOR PSOX=0:0
SET PSOX=$ORDER(^PSRX(J,1,PSOX))
if 'PSOX
QUIT
if $PIECE(^PSRX(J,1,PSOX,0),"^",18)
SET PSOLR=$PIECE(^(0),"^",18)
+27 WRITE !?2,"Last Released: "
if PSOLR
WRITE $EXTRACT(PSOLR,4,5)_"-"_$EXTRACT(PSOLR,6,7)_"-"_$EXTRACT(PSOLR,2,3)
+28 WRITE ?45,$SELECT($PIECE(RX2,"^",15):"Original Fill Returned to Stock",1:"Original Release: "_$SELECT($PIECE(RX2,"^",13):$EXTRACT($PIECE(RX2,"^",13),4,5)_"-"_$EXTRACT($PIECE(RX2,"^",13),6,7)_"-"_$EXTRACT($PIECE(RX2,"^",13),2,3),1:""))
+29 SET CT=0
SET REF=$PIECE(RX0,"^",9)
FOR K=0:0
SET K=$ORDER(^PSRX(J,1,K))
if 'K
QUIT
SET RX1=^PSRX(J,1,K,0)
Begin DoDot:1
+30 IF $Y+5>IOSL
IF IOSL["C-"
DO DIR^PSOP1
WRITE @IOF
if $DATA(PQT)
QUIT
+31 IF $Y+5>IOSL
IF $EXTRACT(IOST)'="C"
SET PAGE=PAGE+1
Begin DoDot:2
+32 WRITE @IOF,!,$PIECE(^DPT(DFN,0),"^"),?70,"Page: "_PAGE
+33 WRITE !?(80-$LENGTH("Medication Profile Sorted by "_HDR))/2,"Medication Profile Sorted by "_HDR
if $GET(FR)]""
WRITE !?(80-$LENGTH(FR_" to "_TO))/2,FR_" to "_TO
+34 WRITE !,PSOPLINE
End DoDot:2
+35 WRITE !?2,"Refilled: "_$EXTRACT($PIECE(RX1,"^"),4,5)_"-"_$EXTRACT($PIECE(RX1,"^"),6,7)_"-"_$EXTRACT($PIECE(RX1,"^"),2,3)_" ("_$PIECE(RX1,"^",2)_")"_$SELECT($PIECE(RX1,"^",16):"(R)",1:"")
+36 WRITE ?30,"Released: "_$SELECT($PIECE(RX1,"^",18):$EXTRACT($PIECE(RX1,"^",18),4,5)_"-"_$EXTRACT($PIECE(RX1,"^",18),6,7)_"-"_$EXTRACT($PIECE(RX1,"^",18),2,3),1:"")
+37 SET REF=REF-1
End DoDot:1
+38 IF $Y+2>IOSL
IF IOSL["C-"
DO DIR^PSOP1
WRITE @IOF
if $DATA(PQT)
QUIT
+39 IF $Y+2>IOSL
IF $EXTRACT(IOST)'="C"
SET PAGE=PAGE+1
WRITE @IOF,!,$PIECE(^DPT(DFN,0),"^"),?70,"Page: "_PAGE
+40 IF $ORDER(^PSRX(J,"P",0))
WRITE !?2,"Partials: "
FOR K=0:0
SET K=$ORDER(^PSRX(J,"P",K))
if 'K
QUIT
WRITE $EXTRACT(^(K,0),4,5),"-",$EXTRACT(^(0),6,7),"-",$EXTRACT(^(0),2,3)," (",$PIECE(^(0),"^",2),") QTY:",$PIECE(^(0),"^",4)_$SELECT($PIECE(^(0),"^",16):" (R)",1:"")_", "
+41 if $PIECE(RX3,"^",7)]""
WRITE !?2,"Remarks: ",$PIECE(RX3,"^",7)
DO STAT^PSOFUNC
+42 SET PSDIV=$SELECT($DATA(^PS(59,+$PIECE(RX2,"^",9),0)):$PIECE(^(0),"^")_" ("_$PIECE(^(0),"^",6)_")",1:"Unknown")
+43 WRITE !?2,"Division: "_$EXTRACT(PSDIV,1,25),?40,ST,?60,REF," Refill"_$SELECT(REF'=1:"s",1:"")," Left"
+44 QUIT
LOOP FOR I=0:0
SET I=$ORDER(^PS(55,DFN,"P",I))
if 'I
QUIT
SET J=+^(I,0)
Begin DoDot:1
+1 SET PSOPATOK=1
IF $PIECE($GET(^PSRX(+$GET(J),0)),"^",2)
IF DFN'=$PIECE($GET(^(0)),"^",2)
KILL ^PS(55,DFN,"P",I,0)
if $PIECE($GET(^PS(55,DFN,"P",0)),"^",4)
SET $PIECE(^PS(55,DFN,"P",0),"^",4)=$PIECE($GET(^(0)),"^",4)-1
SET PSOPATOK=0
End DoDot:1
IF $GET(PSOPATOK)
IF $DATA(^PSRX(J,0))
IF $PIECE($GET(^PSRX(J,"STA")),"^")'=13
SET PRLBL=PSRT_"^PSOP2"
DO @PRLBL
+2 QUIT
