- PSOP ;BIR/SAB - Medication profile long or short ;02/25/94
- ;;7.0;OUTPATIENT PHARMACY;**2,15,98,132,148,326**;DEC 1997;Build 11
- ;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,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,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 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),?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
- 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
- PSOP ;BIR/SAB - Medication profile long or short ;02/25/94
- +1 ;;7.0;OUTPATIENT PHARMACY;**2,15,98,132,148,326**;DEC 1997;Build 11
- +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,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,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
- 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),?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 IF $GET(PQT)
- QUIT
- +20 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)
- +21 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
- +22 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),")"
- +23 IF $PIECE(RX3,"^",3)
- Begin DoDot:1
- +24 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
- +25 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)
- +26 WRITE !?2,"Last Released: "
- IF PSOLR
- WRITE $EXTRACT(PSOLR,4,5)_"-"_$EXTRACT(PSOLR,6,7)_"-"_$EXTRACT(PSOLR,2,3)
- +27 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:""))
- +28 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
- +29 IF $Y+5>IOSL
- IF IOSL["C-"
- DO DIR^PSOP1
- WRITE @IOF
- IF $DATA(PQT)
- QUIT
- +30 IF $Y+5>IOSL
- IF $EXTRACT(IOST)'="C"
- SET PAGE=PAGE+1
- Begin DoDot:2
- +31 WRITE @IOF,!,$PIECE(^DPT(DFN,0),"^"),?70,"Page: "_PAGE
- +32 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
- +33 WRITE !,PSOPLINE
- End DoDot:2
- +34 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:"")
- +35 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:"")
- +36 SET REF=REF-1
- End DoDot:1
- +37 IF $Y+2>IOSL
- IF IOSL["C-"
- DO DIR^PSOP1
- WRITE @IOF
- IF $DATA(PQT)
- QUIT
- +38 IF $Y+2>IOSL
- IF $EXTRACT(IOST)'="C"
- SET PAGE=PAGE+1
- WRITE @IOF,!,$PIECE(^DPT(DFN,0),"^"),?70,"Page: "_PAGE
- +39 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:"")_", "
- +40 IF $PIECE(RX3,"^",7)]""
- WRITE !?2,"Remarks: ",$PIECE(RX3,"^",7)
- DO STAT^PSOFUNC
- +41 SET PSDIV=$SELECT($DATA(^PS(59,+$PIECE(RX2,"^",9),0)):$PIECE(^(0),"^")_" ("_$PIECE(^(0),"^",6)_")",1:"Unknown")
- +42 WRITE !?2,"Division: "_$EXTRACT(PSDIV,1,25),?40,ST,?60,REF," Refill"_$SELECT(REF'=1:"s",1:"")," Left"
- +43 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
