- PSOSD0 ;BHAM ISC/SAB - action or informational profile cont. ;08/24/17 10:10
- ;;7.0;OUTPATIENT PHARMACY;**2,19,40,66,107,110,258,206,441**;DEC 1997;Build 208
- ;External reference to ^PS(50.605 supported by DBIA 696
- ;External reference to ^SC supported by DBIA 10040
- ;External reference to ^PSDRUG supported by DBIA 221
- CLASS S (ZCLASS,CLASS)="",RXCNT=0 F Z0=0:0 S CLASS=$O(^TMP($J,"PRF",CLASS)) Q:CLASS="" S PCLASS=$S($D(^PS(50.605,+$O(^PS(50.605,"B",CLASS,0)),0)):CLASS_" - "_$P(^(0),"^",2),1:"UNCLASSIFIED") D DRUG Q:$D(DTOUT)!($D(DUOUT))
- Q
- DRUG S DRUG="" F Z1=0:0 S DRUG=$O(^TMP($J,"PRF",CLASS,DRUG)) Q:DRUG="" S FDT="" F Z3=0:0 S FDT=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) Q:'FDT D RXN Q:$D(DTOUT)!($D(DUOUT))
- Q
- RXN I PSORM D
- .D:$S($P($G(PSOPAR),"^")&($G(PSTYPE))&('$D(DOD(DFN))):RXCNT=3,'$G(PSTYPE)!($D(DOD(DFN))):RXCNT=6,1:RXCNT=4) HD1^PSOSD2
- I 'PSORM D
- .D:$S($P($G(PSOPAR),"^")&($G(PSTYPE))&('$D(DOD(DFN))):RXCNT=2,1:RXCNT=5) HD1^PSOSD2
- S RXN=0 F Z2=0:0 S RXN=$O(^TMP($J,"PRF",CLASS,DRUG,FDT,RXN)) Q:'RXN D Q:$D(DTOUT)!($D(DUOUT))
- .S RX0=^TMP($J,"PRF",CLASS,DRUG,FDT,RXN),J=RXN,RX2=$S($D(^PSRX(J,2)):^(2),1:""),RX3=$G(^(3)),RXNO=RXN
- .S RXNODE=^PSRX(RXN,0),$P(RXNODE,"^",15)=+$G(^("STA")) D ENSAVE^PSODACT,RXN1
- Q
- RXN1 S RFL=1,FILL(9999999-$P(RX2,"^",2))=+$P(RX2,"^",2)_"^"_$S($P(RX2,"^",15):"(R)",1:""),FILLS=+$P(RX0,"^",9)
- F II=0:0 S II=$O(^PSRX(J,1,II)) Q:'II S FILL(9999999-^PSRX(J,1,II,0))=+^PSRX(J,1,II,0)_"^"_$S($P(^(0),"^",16):"(R)",1:"") S RFL=RFL+1
- S PHYS=$S($D(^VA(200,+$P(RX0,"^",4),0)):$P(^(0),"^"),1:"UNKNOWN")
- I 'PSTYPE,ZCLASS=CLASS,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR Q:$D(DTOUT)!($D(DUOUT)) W !
- I $S($G(PSTYPE):$Y>48,1:$Y>60)!(ZCLASS]""&(ZCLASS'=CLASS)&($S($G(PSTYPE):$Y+16>IOSL,1:$Y+8>IOSL))) D HD1^PSOSD2 Q:$D(DTOUT)!($D(DUOUT))
- I ZCLASS'=CLASS D:$S($G(PSTYPE):$Y>48,1:$Y>60) HD1^PSOSD2 W !,$S('PSORM:"Class: ",1:"Classification: ")_PCLASS,! S ZCLASS=CLASS
- I 'PSORM D EIGHTY Q
- W !,$S('$D(^PSDRUG(+$P(RX0,"^",6),0)):"",+$P(^PSDRUG(+$P(RX0,"^",6),0),"^",9):"N/F",1:"")," ",$S($D(^PSDRUG(+$P(RX0,"^",6),0)):$P(^(0),"^"),1:"NOT ON FILE")
- N ACTS D ACTS
- W ?45,"Qty: "_$P(RX0,"^",7)_" for "_$P(RX0,"^",8)_" Days ",?74,$P(RX0,"^"),?84," ",ACTS,?99,$E($P(RX2,"^",6),4,5)_"-"_$E($P(RX2,"^",6),6,7)_"-"_($E($P(RX2,"^",6),1,3)+1700)
- W ?110,$E(PHYS,1,30) D COS^PSOSDP
- I $G(^PSDRUG(+$P(RX0,"^",6),"PSO"))]"" W !," Message: "_$G(^PSDRUG(+$P(RX0,"^",6),"PSO"))
- S RXCNT=RXCNT+1 D SIG W !?9,"Sig: ",$G(BSIG(1))
- I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV W !?14,$G(BSIG(PSREV))
- K BSIG,PSREV
- S RFS=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFS=RFS+1
- W !?10,"Filled: " F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII S Y=FILL(PSIII) W:Y " ",$E($P(Y,"^"),4,5),"-",$E($P(Y,"^"),6,7),"-",($E($P(Y,"^"),1,3)+1700)_$P(Y,"^",2)
- S DUPD=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) I DUPD,RFL<6 D
- .S OLDRX2=RX2,OLDJ=J,OLDFILL=FDT,OLDRX=RXN W " Past Fills:" D DUP S FDT=OLDFILL,J=OLDJ,RX2=OLDRX2,RXN=OLDRX K OLDJ,OLDRX2,OLDFILL,OLDRX
- W !?10,"Remaining Refills: "_($P(RX0,"^",9)-RFS),?45,"Clinic: ",$S($D(^SC(+$P(RX0,"^",5),0)):$E($P(^(0),"^"),1,30),1:"UNKNOWN")
- W ?105,"Price: " S PRICE=$S($D(^PSDRUG($P(RX0,"^",6),660)):$P(^(660),"^",6),1:0),COST=$P(RX0,"^",7)*PRICE S:COST<1 COST="0"_COST W "$",$J(COST,3,2),! K COST
- I 'PSTYPE D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") ^PSOLAB G RXN2
- G:$G(DOD(DFN))]"" RXN2
- D:+$G(PSOBAR4) BAR S PSRENW=0,PSODEA=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I PSODEA'["1",PSODEA'["2",PSODEA'["W",$P($G(^PS(53,+$P(RX0,"^",3),0)),"^",5) S PSRENW=1
- S PSOIFSUP=$S(PSODEA']"":0,PSODEA["S":1,1:0),RXX=$P(RX0,"^"),RXX(1)="",RXX=$O(^PSRX("B",RXX,RXX(1)))
- W:$P($G(^PSRX(RXX,"IB")),"^") !?11,"****COPAY****" D PSRENW^PSOSD2
- I PSRENW W !?1,$S(PSOIFSUP:"",'$D(PSOPRINT):"",PSOPRINT]"":PSOPRINT,1:""),?11,"RENEW/MD:" F T=1:1:30 W "_" I T=30 W "VA#:" F I=1:1:10 W "_" I I=10 D
- .W "DATE__________ REFILL"
- .W $S($P(RX0,"^",8)'<60&($P(RX0,"^",8)'>89):" 0 1 2"_$S('CS:" 3 4 5",1:""),$P(RX0,"^",8)<60:" 0 1 2 3 4 5"_$S('CS:" 6 7 8 9 10 11",1:""),1:" 0 1"_$S('CS:" 2 3",1:"")),!
- I "ASH"[$E($P(RX0,"^",15)),PSTYPE D
- .W !?21,"DISCONTINUE/MD:" F T=1:1:30 W "_" I T=30 W "VA#:" F I=1:1:10 W "_" I I=10 W "DATE__________",!
- D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") PRINT^PSOLAB
- RXN2 W ! K RX0,RX3,RX2,PRDT,LABEL,PHYS,PSI,PSII,PSIII,II,Y,SIG,X,FILL,FILLS,PHYS,Z9,PRICE,I,T,RXX
- Q
- SIG K FSIG,BSIG I $P($G(^PSRX(RXN,"SIG")),"^",2) D FSIG^PSOUTLA("R",RXN,$S('PSORM:64,$E(IOST)="C":64,1:114)) F PSREV=1:1 Q:'$D(FSIG(PSREV)) S BSIG(PSREV)=FSIG(PSREV)
- K FSIG,PSREV I '$P($G(^PSRX(RXN,"SIG")),"^",2) D EN3^PSOUTLA1(RXN,$S('PSORM:64,$E(IOST)="C":64,1:114))
- Q
- DUP ;DUP DRUG
- F Z4=0:0 Q:RFL>9 S FDT=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) Q:'FDT D
- .F Z5=0:0 S Z5=$O(^TMP($J,"PRF",CLASS,DRUG,FDT,Z5)) Q:'Z5 S RX2=$S($D(^PSRX(Z5,2)):^(2),1:"") D:"DE"[$E($P(^TMP($J,"PRF",CLASS,DRUG,FDT,Z5),"^",15))
- ..K FILL S FILL(9999999-$P(RX2,"^",2))=+$P(RX2,"^",2)_"^"_$S($P(RX2,"^",15):"(R)",1:"") F II=0:0 S II=$O(^PSRX(Z5,1,II)) Q:'II S FILL(9999999-$P(^PSRX(Z5,1,II,0),"^"))=$P(^PSRX(Z5,1,II,0),"^")_"^"_$S($P(^(0),"^",16):"(R)",1:"")
- ..F PSII=0:0 S PSII=$O(FILL(PSII)) Q:'PSII W:($X+8)>$S('PSORM:80,1:IOM) !?9 S Y=FILL(PSII) W " ",$E($P(Y,"^"),4,5)_"-"_$E($P(Y,"^"),6,7)_"-"_($E($P(Y,"^"),1,3)+1700)_$P(Y,"^",2)
- ..K ^TMP($J,"PRF",CLASS,DRUG,FDT,Z5)
- Q
- BAR ;barcode
- I PSOBAR4 S X="S",X2=PSOINST_"-"_RXN W !?15 S X1=$X W @PSOBAR3,X2,@PSOBAR2,$C(13) S $X=0
- Q
- EIGHTY ;prints profile in 80 column format
- W !,$S('$D(^PSDRUG(+$P(RX0,"^",6),0)):"",+$P(^PSDRUG(+$P(RX0,"^",6),0),"^",9):"N/F",1:"")," ",$S($D(^PSDRUG(+$P(RX0,"^",6),0)):$P(^(0),"^"),1:"NOT ON FILE"),?45,"Rx #: "_$P(RX0,"^")
- I $G(^PSDRUG(+$P(RX0,"^",6),"PSO"))]"" W !," Message: "_$G(^PSDRUG(+$P(RX0,"^",6),"PSO"))
- N ACTS D ACTS
- W !?1,"Qty: "_$P(RX0,"^",7)_" for "_$P(RX0,"^",8)_" Days "_ACTS," Exp: "_$E($P(RX2,"^",6),4,5)_"-"_$E($P(RX2,"^",6),6,7)_"-"_($E($P(RX2,"^",6),1,3)+1700)
- W ?48," Prov: "_$E(PHYS,1,30) I $P($G(^PSRX(J,3)),"^",3),$D(^VA(200,+$P($G(^(3)),"^",3),0)) W !,?43,"COSIGNER: "_$P($G(^VA(200,+$P(^PSRX(J,3),"^",3),0)),"^")
- S RXCNT=RXCNT+1 D SIG W !?9,"Sig: ",$G(BSIG(1))
- I $O(BSIG(1)) F PSREV=1:0 S PSREV=$O(BSIG(PSREV)) Q:'PSREV W !?14,$G(BSIG(PSREV))
- K BSIG,PSREV
- S RFS=0 F RF=0:0 S RF=$O(^PSRX(RXN,1,RF)) Q:'RF S RFS=RFS+1
- W !?10,"Filled: " F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII S Y=FILL(PSIII) W:Y " ",$E($P(Y,"^"),4,5),"-",$E($P(Y,"^"),6,7),"-",($E($P(Y,"^"),1,3)+1700)_$P(Y,"^",2)
- S DUPD=$O(^TMP($J,"PRF",CLASS,DRUG,FDT)) I DUPD,RFL<6 D
- .S OLDRX2=RX2,OLDJ=J,OLDFILL=FDT,OLDRX=RXN W " Past Fills:" D DUP S FDT=OLDFILL,J=OLDJ,RX2=OLDRX2,RXN=OLDRX K OLDJ,OLDRX2,OLDFILL,OLDRX
- W !?10,"Remaining Refills: "_($P(RX0,"^",9)-RFS),?45,"Clinic: ",$S($D(^SC(+$P(RX0,"^",5),0)):$E($P(^(0),"^"),1,30),1:"UNKNOWN")
- W !?10,"Price: " S PRICE=$S($D(^PSDRUG($P(RX0,"^",6),660)):$P(^(660),"^",6),1:0),COST=$P(RX0,"^",7)*PRICE S:COST<1 COST="0"_COST W "$",$J(COST,3,2),! K COST
- I 'PSTYPE D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") ^PSOLAB G RXN2
- G:$G(DOD(DFN))]"" RXN3
- D:+$G(PSOBAR4) BAR S PSRENW=0,PSODEA=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I PSODEA'["1",PSODEA'["2",PSODEA'["W",$P($G(^PS(53,+$P(RX0,"^",3),0)),"^",5) S PSRENW=1
- S PSOIFSUP=$S(PSODEA']"":0,PSODEA["S":1,1:0),RXX=$P(RX0,"^"),RXX(1)="",RXX=$O(^PSRX("B",RXX,RXX(1)))
- W:$P($G(^PSRX(RXX,"IB")),"^") !?11,"****COPAY****" D PSRENW^PSOSD2
- I PSRENW W !?1,$S(PSOIFSUP:"",'$D(PSOPRINT):"",PSOPRINT]"":PSOPRINT,1:""),?6,"RENEW/MD:" F T=1:1:30 W "_" I T=30 W "VA#:" F I=1:1:10 W "_" I I=10 D
- .W "DATE__________",!?6,"REFILLS"
- .W $S($P(RX0,"^",8)'<60&($P(RX0,"^",8)'>89):" 0 1 2"_$S('CS:" 3 4 5",1:""),$P(RX0,"^",8)<60:" 0 1 2 3 4 5"_$S('CS:" 6 7 8 9 10 11",1:""),1:" 0 1"_$S('CS:" 2 3",1:"")),!
- I "ASH"[$E($P(RX0,"^",15)),PSTYPE D
- .W !?11,"DISCONTINUE/MD:" F T=1:1:26 W "_" I T=26 W "VA#:" F I=1:1:10 W "_" I I=10 W "DATE__________",!
- D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") PRINT^PSOLAB
- RXN3 W ! K RX0,RX3,RX2,PRDT,LABEL,PHYS,PSI,PSII,PSIII,II,Y,SIG,X,FILL,FILLS,PHYS,Z9,PRICE,I,T,RXX
- Q
- ACTS ;
- S ACTS=$S($P(RX0,"^",15)["PENDING":"PENDING",$P(RX0,"^",15)["Suspended":"Active/Susp",1:$P(RX0,"^",15))
- I +$G(^PSRX(RXN,"STA"))=0,+$G(^PSRX(RXN,"PARK")) S ACTS="Active/Parked" ;441 PAPI
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSD0 8407 printed Jan 18, 2025@03:35:53 Page 2
- PSOSD0 ;BHAM ISC/SAB - action or informational profile cont. ;08/24/17 10:10
- +1 ;;7.0;OUTPATIENT PHARMACY;**2,19,40,66,107,110,258,206,441**;DEC 1997;Build 208
- +2 ;External reference to ^PS(50.605 supported by DBIA 696
- +3 ;External reference to ^SC supported by DBIA 10040
- +4 ;External reference to ^PSDRUG supported by DBIA 221
- CLASS SET (ZCLASS,CLASS)=""
- SET RXCNT=0
- FOR Z0=0:0
- SET CLASS=$ORDER(^TMP($JOB,"PRF",CLASS))
- if CLASS=""
- QUIT
- SET PCLASS=$SELECT($DATA(^PS(50.605,+$ORDER(^PS(50.605,"B",CLASS,0)),0)):CLASS_" - "_$PIECE(^(0),"^",2),1:"UNCLASSIFIED")
- DO DRUG
- if $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +1 QUIT
- DRUG SET DRUG=""
- FOR Z1=0:0
- SET DRUG=$ORDER(^TMP($JOB,"PRF",CLASS,DRUG))
- if DRUG=""
- QUIT
- SET FDT=""
- FOR Z3=0:0
- SET FDT=$ORDER(^TMP($JOB,"PRF",CLASS,DRUG,FDT))
- if 'FDT
- QUIT
- DO RXN
- if $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +1 QUIT
- RXN IF PSORM
- Begin DoDot:1
- +1 if $SELECT($PIECE($GET(PSOPAR),"^")&($GET(PSTYPE))&('$DATA(DOD(DFN)))
- DO HD1^PSOSD2
- End DoDot:1
- +2 IF 'PSORM
- Begin DoDot:1
- +3 if $SELECT($PIECE($GET(PSOPAR),"^")&($GET(PSTYPE))&('$DATA(DOD(DFN)))
- DO HD1^PSOSD2
- End DoDot:1
- +4 SET RXN=0
- FOR Z2=0:0
- SET RXN=$ORDER(^TMP($JOB,"PRF",CLASS,DRUG,FDT,RXN))
- if 'RXN
- QUIT
- Begin DoDot:1
- +5 SET RX0=^TMP($JOB,"PRF",CLASS,DRUG,FDT,RXN)
- SET J=RXN
- SET RX2=$SELECT($DATA(^PSRX(J,2)):^(2),1:"")
- SET RX3=$GET(^(3))
- SET RXNO=RXN
- +6 SET RXNODE=^PSRX(RXN,0)
- SET $PIECE(RXNODE,"^",15)=+$GET(^("STA"))
- DO ENSAVE^PSODACT
- DO RXN1
- End DoDot:1
- if $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +7 QUIT
- RXN1 SET RFL=1
- SET FILL(9999999-$PIECE(RX2,"^",2))=+$PIECE(RX2,"^",2)_"^"_$SELECT($PIECE(RX2,"^",15):"(R)",1:"")
- SET FILLS=+$PIECE(RX0,"^",9)
- +1 FOR II=0:0
- SET II=$ORDER(^PSRX(J,1,II))
- if 'II
- QUIT
- SET FILL(9999999-^PSRX(J,1,II,0))=+^PSRX(J,1,II,0)_"^"_$SELECT($PIECE(^(0),"^",16):"(R)",1:"")
- SET RFL=RFL+1
- +2 SET PHYS=$SELECT($DATA(^VA(200,+$PIECE(RX0,"^",4),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
- +3 IF 'PSTYPE
- IF ZCLASS=CLASS
- IF $EXTRACT(IOST)="C"
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- if $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- WRITE !
- +4 IF $SELECT($GET(PSTYPE):$Y>48,1:$Y>60)!(ZCLASS]""&(ZCLASS'=CLASS)&($SELECT($GET(PSTYPE):$Y+16>IOSL,1:$Y+8>IOSL)))
- DO HD1^PSOSD2
- if $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +5 IF ZCLASS'=CLASS
- if $SELECT($GET(PSTYPE)
- DO HD1^PSOSD2
- WRITE !,$SELECT('PSORM:"Class: ",1:"Classification: ")_PCLASS,!
- SET ZCLASS=CLASS
- +6 IF 'PSORM
- DO EIGHTY
- QUIT
- +7 WRITE !,$SELECT('$DATA(^PSDRUG(+$PIECE(RX0,"^",6),0)):"",+$PIECE(^PSDRUG(+$PIECE(RX0,"^",6),0),"^",9):"N/F",1:"")," ",$SELECT($DATA(^PSDRUG(+$PIECE(RX0,"^",6),0)):$PIECE(^(0),"^"),1:"NOT ON FILE")
- +8 NEW ACTS
- DO ACTS
- +9 WRITE ?45,"Qty: "_$PIECE(RX0,"^",7)_" for "_$PIECE(RX0,"^",8)_" Days ",?74,$PIECE(RX0,"^"),?84," ",ACTS,?99,$EXTRACT($PIECE(RX2,"^",6),4,5)_"-"_$EXTRACT($PIECE(RX2,"^",6),6,7)_"-"_($EXTRACT($PIECE(RX2,"^",6),1,3)+1700)
- +10 WRITE ?110,$EXTRACT(PHYS,1,30)
- DO COS^PSOSDP
- +11 IF $GET(^PSDRUG(+$PIECE(RX0,"^",6),"PSO"))]""
- WRITE !," Message: "_$GET(^PSDRUG(+$PIECE(RX0,"^",6),"PSO"))
- +12 SET RXCNT=RXCNT+1
- DO SIG
- WRITE !?9,"Sig: ",$GET(BSIG(1))
- +13 IF $ORDER(BSIG(1))
- FOR PSREV=1:0
- SET PSREV=$ORDER(BSIG(PSREV))
- if 'PSREV
- QUIT
- WRITE !?14,$GET(BSIG(PSREV))
- +14 KILL BSIG,PSREV
- +15 SET RFS=0
- FOR RF=0:0
- SET RF=$ORDER(^PSRX(RXN,1,RF))
- if 'RF
- QUIT
- SET RFS=RFS+1
- +16 WRITE !?10,"Filled: "
- FOR PSIII=0:0
- SET PSIII=$ORDER(FILL(PSIII))
- if 'PSIII
- QUIT
- SET Y=FILL(PSIII)
- if Y
- WRITE " ",$EXTRACT($PIECE(Y,"^"),4,5),"-",$EXTRACT($PIECE(Y,"^"),6,7),"-",($EXTRACT($PIECE(Y,"^"),1,3)+1700)_$PIECE(Y,"^",2)
- +17 SET DUPD=$ORDER(^TMP($JOB,"PRF",CLASS,DRUG,FDT))
- IF DUPD
- IF RFL<6
- Begin DoDot:1
- +18 SET OLDRX2=RX2
- SET OLDJ=J
- SET OLDFILL=FDT
- SET OLDRX=RXN
- WRITE " Past Fills:"
- DO DUP
- SET FDT=OLDFILL
- SET J=OLDJ
- SET RX2=OLDRX2
- SET RXN=OLDRX
- KILL OLDJ,OLDRX2,OLDFILL,OLDRX
- End DoDot:1
- +19 WRITE !?10,"Remaining Refills: "_($PIECE(RX0,"^",9)-RFS),?45,"Clinic: ",$SELECT($DATA(^SC(+$PIECE(RX0,"^",5),0)):$EXTRACT($PIECE(^(0),"^"),1,30),1:"UNKNOWN")
- +20 WRITE ?105,"Price: "
- SET PRICE=$SELECT($DATA(^PSDRUG($PIECE(RX0,"^",6),660)):$PIECE(^(660),"^",6),1:0)
- SET COST=$PIECE(RX0,"^",7)*PRICE
- if COST<1
- SET COST="0"_COST
- WRITE "$",$JUSTIFY(COST,3,2),!
- KILL COST
- +21 IF 'PSTYPE
- if $DATA(^PSDRUG(+$PIECE(RX0,"^",6),"CLOZ"))&($PIECE($GET(^("CLOZ1")),"^")'="PSOCLO1")
- DO ^PSOLAB
- GOTO RXN2
- +22 if $GET(DOD(DFN))]""
- GOTO RXN2
- +23 if +$GET(PSOBAR4)
- DO BAR
- SET PSRENW=0
- SET PSODEA=$PIECE($GET(^PSDRUG(+$PIECE(RX0,"^",6),0)),"^",3)
- IF PSODEA'["1"
- IF PSODEA'["2"
- IF PSODEA'["W"
- IF $PIECE($GET(^PS(53,+$PIECE(RX0,"^",3),0)),"^",5)
- SET PSRENW=1
- +24 SET PSOIFSUP=$SELECT(PSODEA']"":0,PSODEA["S":1,1:0)
- SET RXX=$PIECE(RX0,"^")
- SET RXX(1)=""
- SET RXX=$ORDER(^PSRX("B",RXX,RXX(1)))
- +25 if $PIECE($GET(^PSRX(RXX,"IB")),"^")
- WRITE !?11,"****COPAY****"
- DO PSRENW^PSOSD2
- +26 IF PSRENW
- WRITE !?1,$SELECT(PSOIFSUP:"",'$DATA(PSOPRINT):"",PSOPRINT]"":PSOPRINT,1:""),?11,"RENEW/MD:"
- FOR T=1:1:30
- WRITE "_"
- IF T=30
- WRITE "VA#:"
- FOR I=1:1:10
- WRITE "_"
- IF I=10
- Begin DoDot:1
- +27 WRITE "DATE__________ REFILL"
- +28 WRITE $SELECT($PIECE(RX0,"^",8)'<60&($PIECE(RX0,"^",8)'>89):" 0 1 2"_$SELECT('CS:" 3 4 5",1:""),$PIECE(RX0,"^",8)<60:" 0 1 2 3 4 5"_$SELECT('CS:" 6 7 8 9 10 11",1:""),1:" 0 1"_$SELECT('CS:" 2 3",1:"")),!
- End DoDot:1
- +29 IF "ASH"[$EXTRACT($PIECE(RX0,"^",15))
- IF PSTYPE
- Begin DoDot:1
- +30 WRITE !?21,"DISCONTINUE/MD:"
- FOR T=1:1:30
- WRITE "_"
- IF T=30
- WRITE "VA#:"
- FOR I=1:1:10
- WRITE "_"
- IF I=10
- WRITE "DATE__________",!
- End DoDot:1
- +31 if $DATA(^PSDRUG(+$PIECE(RX0,"^",6),"CLOZ"))&($PIECE($GET(^("CLOZ1")),"^")'="PSOCLO1")
- DO PRINT^PSOLAB
- RXN2 WRITE !
- KILL RX0,RX3,RX2,PRDT,LABEL,PHYS,PSI,PSII,PSIII,II,Y,SIG,X,FILL,FILLS,PHYS,Z9,PRICE,I,T,RXX
- +1 QUIT
- SIG KILL FSIG,BSIG
- IF $PIECE($GET(^PSRX(RXN,"SIG")),"^",2)
- DO FSIG^PSOUTLA("R",RXN,$SELECT('PSORM:64,$EXTRACT(IOST)="C":64,1:114))
- FOR PSREV=1:1
- if '$DATA(FSIG(PSREV))
- QUIT
- SET BSIG(PSREV)=FSIG(PSREV)
- +1 KILL FSIG,PSREV
- IF '$PIECE($GET(^PSRX(RXN,"SIG")),"^",2)
- DO EN3^PSOUTLA1(RXN,$SELECT('PSORM:64,$EXTRACT(IOST)="C":64,1:114))
- +2 QUIT
- DUP ;DUP DRUG
- +1 FOR Z4=0:0
- if RFL>9
- QUIT
- SET FDT=$ORDER(^TMP($JOB,"PRF",CLASS,DRUG,FDT))
- if 'FDT
- QUIT
- Begin DoDot:1
- +2 FOR Z5=0:0
- SET Z5=$ORDER(^TMP($JOB,"PRF",CLASS,DRUG,FDT,Z5))
- if 'Z5
- QUIT
- SET RX2=$SELECT($DATA(^PSRX(Z5,2)):^(2),1:"")
- if "DE"[$EXTRACT($PIECE(^TMP($JOB,"PRF",CLASS,DRUG,FDT,Z5),"^",15))
- Begin DoDot:2
- +3 KILL FILL
- SET FILL(9999999-$PIECE(RX2,"^",2))=+$PIECE(RX2,"^",2)_"^"_$SELECT($PIECE(RX2,"^",15):"(R)",1:"")
- FOR II=0:0
- SET II=$ORDER(^PSRX(Z5,1,II))
- if 'II
- QUIT
- SET FILL(9999999-$PIECE(^PSRX(Z5,1,II,0),"^"))=$PIECE(^PSRX(Z5,1,II,0),"^")_"^"_$SELECT($PIECE(^(0),"^",16):"(R)",1:"")
- +4 FOR PSII=0:0
- SET PSII=$ORDER(FILL(PSII))
- if 'PSII
- QUIT
- if ($X+8)>$SELECT('PSORM
- WRITE !?9
- SET Y=FILL(PSII)
- WRITE " ",$EXTRACT($PIECE(Y,"^"),4,5)_"-"_$EXTRACT($PIECE(Y,"^"),6,7)_"-"_($EXTRACT($PIECE(Y,"^"),1,3)+1700)_$PIECE(Y,"^",2)
- +5 KILL ^TMP($JOB,"PRF",CLASS,DRUG,FDT,Z5)
- End DoDot:2
- End DoDot:1
- +6 QUIT
- BAR ;barcode
- +1 IF PSOBAR4
- SET X="S"
- SET X2=PSOINST_"-"_RXN
- WRITE !?15
- SET X1=$X
- WRITE @PSOBAR3,X2,@PSOBAR2,$CHAR(13)
- SET $X=0
- +2 QUIT
- EIGHTY ;prints profile in 80 column format
- +1 WRITE !,$SELECT('$DATA(^PSDRUG(+$PIECE(RX0,"^",6),0)):"",+$PIECE(^PSDRUG(+$PIECE(RX0,"^",6),0),"^",9):"N/F",1:"")," ",$SELECT($DATA(^PSDRUG(+$PIECE(RX0,"^",6),0)):$PIECE(^(0),"^"),1:"NOT ON FILE"),?45,"Rx #: "_$PIECE(RX0,"^")
- +2 IF $GET(^PSDRUG(+$PIECE(RX0,"^",6),"PSO"))]""
- WRITE !," Message: "_$GET(^PSDRUG(+$PIECE(RX0,"^",6),"PSO"))
- +3 NEW ACTS
- DO ACTS
- +4 WRITE !?1,"Qty: "_$PIECE(RX0,"^",7)_" for "_$PIECE(RX0,"^",8)_" Days "_ACTS," Exp: "_$EXTRACT($PIECE(RX2,"^",6),4,5)_"-"_$EXTRACT($PIECE(RX2,"^",6),6,7)_"-"_($EXTRACT($PIECE(RX2,"^",6),1,3)+1700)
- +5 WRITE ?48," Prov: "_$EXTRACT(PHYS,1,30)
- IF $PIECE($GET(^PSRX(J,3)),"^",3)
- IF $DATA(^VA(200,+$PIECE($GET(^(3)),"^",3),0))
- WRITE !,?43,"COSIGNER: "_$PIECE($GET(^VA(200,+$PIECE(^PSRX(J,3),"^",3),0)),"^")
- +6 SET RXCNT=RXCNT+1
- DO SIG
- WRITE !?9,"Sig: ",$GET(BSIG(1))
- +7 IF $ORDER(BSIG(1))
- FOR PSREV=1:0
- SET PSREV=$ORDER(BSIG(PSREV))
- if 'PSREV
- QUIT
- WRITE !?14,$GET(BSIG(PSREV))
- +8 KILL BSIG,PSREV
- +9 SET RFS=0
- FOR RF=0:0
- SET RF=$ORDER(^PSRX(RXN,1,RF))
- if 'RF
- QUIT
- SET RFS=RFS+1
- +10 WRITE !?10,"Filled: "
- FOR PSIII=0:0
- SET PSIII=$ORDER(FILL(PSIII))
- if 'PSIII
- QUIT
- SET Y=FILL(PSIII)
- if Y
- WRITE " ",$EXTRACT($PIECE(Y,"^"),4,5),"-",$EXTRACT($PIECE(Y,"^"),6,7),"-",($EXTRACT($PIECE(Y,"^"),1,3)+1700)_$PIECE(Y,"^",2)
- +11 SET DUPD=$ORDER(^TMP($JOB,"PRF",CLASS,DRUG,FDT))
- IF DUPD
- IF RFL<6
- Begin DoDot:1
- +12 SET OLDRX2=RX2
- SET OLDJ=J
- SET OLDFILL=FDT
- SET OLDRX=RXN
- WRITE " Past Fills:"
- DO DUP
- SET FDT=OLDFILL
- SET J=OLDJ
- SET RX2=OLDRX2
- SET RXN=OLDRX
- KILL OLDJ,OLDRX2,OLDFILL,OLDRX
- End DoDot:1
- +13 WRITE !?10,"Remaining Refills: "_($PIECE(RX0,"^",9)-RFS),?45,"Clinic: ",$SELECT($DATA(^SC(+$PIECE(RX0,"^",5),0)):$EXTRACT($PIECE(^(0),"^"),1,30),1:"UNKNOWN")
- +14 WRITE !?10,"Price: "
- SET PRICE=$SELECT($DATA(^PSDRUG($PIECE(RX0,"^",6),660)):$PIECE(^(660),"^",6),1:0)
- SET COST=$PIECE(RX0,"^",7)*PRICE
- if COST<1
- SET COST="0"_COST
- WRITE "$",$JUSTIFY(COST,3,2),!
- KILL COST
- +15 IF 'PSTYPE
- if $DATA(^PSDRUG(+$PIECE(RX0,"^",6),"CLOZ"))&($PIECE($GET(^("CLOZ1")),"^")'="PSOCLO1")
- DO ^PSOLAB
- GOTO RXN2
- +16 if $GET(DOD(DFN))]""
- GOTO RXN3
- +17 if +$GET(PSOBAR4)
- DO BAR
- SET PSRENW=0
- SET PSODEA=$PIECE($GET(^PSDRUG(+$PIECE(RX0,"^",6),0)),"^",3)
- IF PSODEA'["1"
- IF PSODEA'["2"
- IF PSODEA'["W"
- IF $PIECE($GET(^PS(53,+$PIECE(RX0,"^",3),0)),"^",5)
- SET PSRENW=1
- +18 SET PSOIFSUP=$SELECT(PSODEA']"":0,PSODEA["S":1,1:0)
- SET RXX=$PIECE(RX0,"^")
- SET RXX(1)=""
- SET RXX=$ORDER(^PSRX("B",RXX,RXX(1)))
- +19 if $PIECE($GET(^PSRX(RXX,"IB")),"^")
- WRITE !?11,"****COPAY****"
- DO PSRENW^PSOSD2
- +20 IF PSRENW
- WRITE !?1,$SELECT(PSOIFSUP:"",'$DATA(PSOPRINT):"",PSOPRINT]"":PSOPRINT,1:""),?6,"RENEW/MD:"
- FOR T=1:1:30
- WRITE "_"
- IF T=30
- WRITE "VA#:"
- FOR I=1:1:10
- WRITE "_"
- IF I=10
- Begin DoDot:1
- +21 WRITE "DATE__________",!?6,"REFILLS"
- +22 WRITE $SELECT($PIECE(RX0,"^",8)'<60&($PIECE(RX0,"^",8)'>89):" 0 1 2"_$SELECT('CS:" 3 4 5",1:""),$PIECE(RX0,"^",8)<60:" 0 1 2 3 4 5"_$SELECT('CS:" 6 7 8 9 10 11",1:""),1:" 0 1"_$SELECT('CS:" 2 3",1:"")),!
- End DoDot:1
- +23 IF "ASH"[$EXTRACT($PIECE(RX0,"^",15))
- IF PSTYPE
- Begin DoDot:1
- +24 WRITE !?11,"DISCONTINUE/MD:"
- FOR T=1:1:26
- WRITE "_"
- IF T=26
- WRITE "VA#:"
- FOR I=1:1:10
- WRITE "_"
- IF I=10
- WRITE "DATE__________",!
- End DoDot:1
- +25 if $DATA(^PSDRUG(+$PIECE(RX0,"^",6),"CLOZ"))&($PIECE($GET(^("CLOZ1")),"^")'="PSOCLO1")
- DO PRINT^PSOLAB
- RXN3 WRITE !
- KILL RX0,RX3,RX2,PRDT,LABEL,PHYS,PSI,PSII,PSIII,II,Y,SIG,X,FILL,FILLS,PHYS,Z9,PRICE,I,T,RXX
- +1 QUIT
- ACTS ;
- +1 SET ACTS=$SELECT($PIECE(RX0,"^",15)["PENDING":"PENDING",$PIECE(RX0,"^",15)["Suspended":"Active/Susp",1:$PIECE(RX0,"^",15))
- +2 ;441 PAPI
- IF +$GET(^PSRX(RXN,"STA"))=0
- IF +$GET(^PSRX(RXN,"PARK"))
- SET ACTS="Active/Parked"
- +3 QUIT