PSOPRFSS ;BHAM ISC/SAB - PRINTS A PROFILE FROM SUSPENSE ; 11/18/92 19:38
;;7.0;OUTPATIENT PHARMACY;**19,300,320,326**;DEC 1997;Build 11
;PHARMACIST IN REVEIWING RX'S WHEN ADDING A 'NEW' RX
Q D CUTDATE^PSOFUNC
QOLD D PLBL^PSORXL
Q
;
DQ D START Q
;
START D:('$D(PSOBMST)) EN1P^PSOBSET K Z I '$D(PSODTCUT) D CUTDATE^PSOFUNC
S:'$D(Z) Z=1 S:'$D(NEW1) (NEW1,NEW11)="^" S %DT="",X="T" D ^%DT S DT=Y S X1=DT,X2=-365 D C^%DTC S EXPS=X S X1=DT,X2=-182 D C^%DTC S EXP=X
K ^TMP($J,"PRF") S LINE="" F I=1:1:110 S LINE=LINE_"-"
F RXX=0:0 S RXX=$O(^PS(55,DFN,"P",RXX)) Q:'RXX S RXNN=+^(RXX,0) I $D(^PSRX(RXNN,0)),$P($G(^("STA")),"^")'=13 S RXPX=^PSRX(RXNN,0),$P(RXPX,"^",15)=$P($G(^("STA")),"^"),RXPX2=^(2) D CHK
D HD I '$D(^TMP($J,"PRF")) W !!?Z+15,"****** NO RX DATA ******",! G PPP
;
SD F SD="A","C","S" W:SD="S" !,?Z+1,"SUPPLIES",$E(LINE,1,89) I $D(^TMP($J,"PRF",SD)) S DRNME="" D DRNME
PPP D PEND^PSOPRF
W !!,"NAME: "_$P(^DPT(DFN,0),"^"),!
W:IOF]"" @IOF K ^TMP($J,"PRF"),A,B,DRNME,DRP,EXP,EXPS,I,II,ISSD,J,LINE,LN,MESS,MJK,NEW1,NEW11,PHYS,POP,QTY,TTTT,RFL,RFS,RXF,RXNN,RXPX,RXPX2,RXPNO,RXX,SD,SIG,STA,X,X1,X2,Y,Z
Q
;
DRNME S DRNME=$O(^TMP($J,"PRF",SD,DRNME)) Q:DRNME="" D ISSD G DRNME
;
ISSD F ISSD=0:0 S ISSD=$O(^TMP($J,"PRF",SD,DRNME,ISSD)) Q:'ISSD S RXPNO="" D RXPNO
Q
;
RXPNO S RXPNO=$O(^TMP($J,"PRF",SD,DRNME,ISSD,RXPNO)) Q:RXPNO="" S RXNN=^(RXPNO) I $D(^PSRX(RXNN,0)) S RXPX=^(0),RXPX2=^(2) D PRT G RXPNO
W "END***************"
;
CHK Q:PSODTCUT>$P(RXPX2,"^",6)
I $P(^PSRX(RXNN,"STA"),"^")=12 S II=RXNN D LAST^PSORFL Q:PSODTCUT>RFDATE
I $P(RXPX,"^",3)=7!($P(RXPX,"^",3)=8)&('PSOPRPAS) Q
S J="^"_RXNN_"^" Q:(NEW1[J)!(NEW11[J) Q:$P(RXPX,"^",13)<EXPS S RXPNO=$P(RXPX,"^"),ISSD=$P(RXPX,"^",13)
Q:'$D(^PSDRUG($P(RXPX,"^",6),0)) S DRP=^(0),SD=$S($P(DRP,"^",3)["S":"S",$P(RXPX,"^",15)=12:"C",1:"A"),DRNME=$P(DRP,"^"),^TMP($J,"PRF",SD,DRNME,ISSD,RXPNO)=RXNN
Q
;
PRT S RFS=$P(RXPX,"^",9),QTY=$P(RXPX,"^",7)
S PHYS=$S($D(^VA(200,$P(RXPX,"^",4),0)):$P(^(0),"^"),1:"UNKNOWN"),II=RXNN D LAST^PSORFL S RXF=0 F MJK=0:0 S MJK=$O(^PSRX(RXNN,1,MJK)) Q:'MJK S RXF=RXF+1
S STA=$S($P(^PSRX(RXNN,"STA"),"^")=14:"DC",$P(^PSRX(RXNN,"STA"),"^")=15:"DE",$P(^PSRX(RXNN,"STA"),"^")=16:"PH",1:$E("ANRHPS ECD",(1+$P(^PSRX(RXNN,"STA"),"^")))),STA=$S(DT>$P(RXPX2,"^",6):"E",1:STA)
W !,?Z+1,RXPNO,?Z+15,DRNME,?Z+55,$E(ISSD,4,5),"/",$E(ISSD,6,7)," ",$E(RFL,1,5)," ",?Z+67,$J(RFS,2)," ",$J(RXF,2)," ",?Z+73,$J(QTY,12)," ",?Z+86,STA," ",?Z+88,$E(PHYS,1,20)
D SIG^PSOPRF F TTTT=0:0 S TTTT=$O(FSIG(TTTT)) Q:'TTTT W !,?Z+19,FSIG(TTTT)
Q
;
HD D PID^VADPT
W !,?Z+17,"PRESCRIPTION PROFILE AS OF ",$E(DT,4,5),"/",$E(DT,6,7),"/",($E(DT,1,3)+1700)
W !!,?Z+20,"NAME: ",$P(^DPT(DFN,0),"^")
I $D(^PS(55,DFN,1)) S MESS=^(1),LN=$L(MESS),A=0 W ! F B=1:1 Q:$P(MESS," ",B,99)="" W:$X>(Z+63) ! W ?Z+31,$P(MESS," ",B)," "
I $$RDI^PSORMRX(DFN) W !!,"THIS PATIENT HAS PRESCRIPTIONS AT OTHER FACILITIES"
W !!?Z+20,"PHARMACIST: ___________________________ DATE: ____________"
W !!?Z+52," DATES ",?Z+67,"REFS ",?Z+86,"S"
W !?Z+1,"RX # ",?Z+15,"DRUG/STRENGTH/SIG",?Z+55,"ISSD LAST ",?Z+67,"AL AC",?Z+77,"QTY",?Z+86,"T",?Z+93,"PROVIDER"
W !?Z+1,$E(LINE,1,12),?Z+15,$E(LINE,1,35),?Z+55,"----- -----",?Z+67,"-- --",?Z+73,"------------",?Z+86,"-",?Z+88,$E(LINE,1,20)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPRFSS 3312 printed Oct 16, 2024@18:33:39 Page 2
PSOPRFSS ;BHAM ISC/SAB - PRINTS A PROFILE FROM SUSPENSE ; 11/18/92 19:38
+1 ;;7.0;OUTPATIENT PHARMACY;**19,300,320,326**;DEC 1997;Build 11
+2 ;PHARMACIST IN REVEIWING RX'S WHEN ADDING A 'NEW' RX
Q DO CUTDATE^PSOFUNC
QOLD DO PLBL^PSORXL
+1 QUIT
+2 ;
DQ DO START
QUIT
+1 ;
START if ('$DATA(PSOBMST))
DO EN1P^PSOBSET
KILL Z
IF '$DATA(PSODTCUT)
DO CUTDATE^PSOFUNC
+1 if '$DATA(Z)
SET Z=1
if '$DATA(NEW1)
SET (NEW1,NEW11)="^"
SET %DT=""
SET X="T"
DO ^%DT
SET DT=Y
SET X1=DT
SET X2=-365
DO C^%DTC
SET EXPS=X
SET X1=DT
SET X2=-182
DO C^%DTC
SET EXP=X
+2 KILL ^TMP($JOB,"PRF")
SET LINE=""
FOR I=1:1:110
SET LINE=LINE_"-"
+3 FOR RXX=0:0
SET RXX=$ORDER(^PS(55,DFN,"P",RXX))
if 'RXX
QUIT
SET RXNN=+^(RXX,0)
IF $DATA(^PSRX(RXNN,0))
IF $PIECE($GET(^("STA")),"^")'=13
SET RXPX=^PSRX(RXNN,0)
SET $PIECE(RXPX,"^",15)=$PIECE($GET(^("STA")),"^")
SET RXPX2=^(2)
DO CHK
+4 DO HD
IF '$DATA(^TMP($JOB,"PRF"))
WRITE !!?Z+15,"****** NO RX DATA ******",!
GOTO PPP
+5 ;
SD FOR SD="A","C","S"
if SD="S"
WRITE !,?Z+1,"SUPPLIES",$EXTRACT(LINE,1,89)
IF $DATA(^TMP($JOB,"PRF",SD))
SET DRNME=""
DO DRNME
PPP DO PEND^PSOPRF
+1 WRITE !!,"NAME: "_$PIECE(^DPT(DFN,0),"^"),!
+2 if IOF]""
WRITE @IOF
KILL ^TMP($JOB,"PRF"),A,B,DRNME,DRP,EXP,EXPS,I,II,ISSD,J,LINE,LN,MESS,MJK,NEW1,NEW11,PHYS,POP,QTY,TTTT,RFL,RFS,RXF,RXNN,RXPX,RXPX2,RXPNO,RXX,SD,SIG,STA,X,X1,X2,Y,Z
+3 QUIT
+4 ;
DRNME SET DRNME=$ORDER(^TMP($JOB,"PRF",SD,DRNME))
if DRNME=""
QUIT
DO ISSD
GOTO DRNME
+1 ;
ISSD FOR ISSD=0:0
SET ISSD=$ORDER(^TMP($JOB,"PRF",SD,DRNME,ISSD))
if 'ISSD
QUIT
SET RXPNO=""
DO RXPNO
+1 QUIT
+2 ;
RXPNO SET RXPNO=$ORDER(^TMP($JOB,"PRF",SD,DRNME,ISSD,RXPNO))
if RXPNO=""
QUIT
SET RXNN=^(RXPNO)
IF $DATA(^PSRX(RXNN,0))
SET RXPX=^(0)
SET RXPX2=^(2)
DO PRT
GOTO RXPNO
+1 WRITE "END***************"
+2 ;
CHK if PSODTCUT>$PIECE(RXPX2,"^",6)
QUIT
+1 IF $PIECE(^PSRX(RXNN,"STA"),"^")=12
SET II=RXNN
DO LAST^PSORFL
if PSODTCUT>RFDATE
QUIT
+2 IF $PIECE(RXPX,"^",3)=7!($PIECE(RXPX,"^",3)=8)&('PSOPRPAS)
QUIT
+3 SET J="^"_RXNN_"^"
if (NEW1[J)!(NEW11[J)
QUIT
if $PIECE(RXPX,"^",13)<EXPS
QUIT
SET RXPNO=$PIECE(RXPX,"^")
SET ISSD=$PIECE(RXPX,"^",13)
+4 if '$DATA(^PSDRUG($PIECE(RXPX,"^",6),0))
QUIT
SET DRP=^(0)
SET SD=$SELECT($PIECE(DRP,"^",3)["S":"S",$PIECE(RXPX,"^",15)=12:"C",1:"A")
SET DRNME=$PIECE(DRP,"^")
SET ^TMP($JOB,"PRF",SD,DRNME,ISSD,RXPNO)=RXNN
+5 QUIT
+6 ;
PRT SET RFS=$PIECE(RXPX,"^",9)
SET QTY=$PIECE(RXPX,"^",7)
+1 SET PHYS=$SELECT($DATA(^VA(200,$PIECE(RXPX,"^",4),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
SET II=RXNN
DO LAST^PSORFL
SET RXF=0
FOR MJK=0:0
SET MJK=$ORDER(^PSRX(RXNN,1,MJK))
if 'MJK
QUIT
SET RXF=RXF+1
+2 SET STA=$SELECT($PIECE(^PSRX(RXNN,"STA"),"^")=14:"DC",$PIECE(^PSRX(RXNN,"STA"),"^")=15:"DE",$PIECE(^PSRX(RXNN,"STA"),"^")=16:"PH",1:$EXTRACT("ANRHPS ECD",(1+$PIECE(^PSRX(RXNN,"STA"),"^"))))
SET STA=$SELECT(DT>$PIECE(RXPX2,"^",6):"E",1:STA)
+3 WRITE !,?Z+1,RXPNO,?Z+15,DRNME,?Z+55,$EXTRACT(ISSD,4,5),"/",$EXTRACT(ISSD,6,7)," ",$EXTRACT(RFL,1,5)," ",?Z+67,$JUSTIFY(RFS,2)," ",$JUSTIFY(RXF,2)," ",?Z+73,$JUSTIFY(QTY,12)," ",?Z+86,STA," ",?Z+88,$EXTRACT(PHYS,1,20)
+4 DO SIG^PSOPRF
FOR TTTT=0:0
SET TTTT=$ORDER(FSIG(TTTT))
if 'TTTT
QUIT
WRITE !,?Z+19,FSIG(TTTT)
+5 QUIT
+6 ;
HD DO PID^VADPT
+1 WRITE !,?Z+17,"PRESCRIPTION PROFILE AS OF ",$EXTRACT(DT,4,5),"/",$EXTRACT(DT,6,7),"/",($EXTRACT(DT,1,3)+1700)
+2 WRITE !!,?Z+20,"NAME: ",$PIECE(^DPT(DFN,0),"^")
+3 IF $DATA(^PS(55,DFN,1))
SET MESS=^(1)
SET LN=$LENGTH(MESS)
SET A=0
WRITE !
FOR B=1:1
if $PIECE(MESS," ",B,99)=""
QUIT
if $X>(Z+63)
WRITE !
WRITE ?Z+31,$PIECE(MESS," ",B)," "
+4 IF $$RDI^PSORMRX(DFN)
WRITE !!,"THIS PATIENT HAS PRESCRIPTIONS AT OTHER FACILITIES"
+5 WRITE !!?Z+20,"PHARMACIST: ___________________________ DATE: ____________"
+6 WRITE !!?Z+52," DATES ",?Z+67,"REFS ",?Z+86,"S"
+7 WRITE !?Z+1,"RX # ",?Z+15,"DRUG/STRENGTH/SIG",?Z+55,"ISSD LAST ",?Z+67,"AL AC",?Z+77,"QTY",?Z+86,"T",?Z+93,"PROVIDER"
+8 WRITE !?Z+1,$EXTRACT(LINE,1,12),?Z+15,$EXTRACT(LINE,1,35),?Z+55,"----- -----",?Z+67,"-- --",?Z+73,"------------",?Z+86,"-",?Z+88,$EXTRACT(LINE,1,20)
