MCPSOP ;WISC/DMA-PHARMACY PATIENT PROFILE (MEDICINE VERS) ;7/30/96 10:39
;;2.3;Medicine;;09/13/1996
;modified from pharmacy to quit after displaying for one pt.
Q:'$D(MCRH) ;quit if not entered from rheumatology module
DOIT S (FN,DFN,D0,DA)=+Y I '$D(^PS(55,+Y,"P")),'$D(^("ARC")) W !?20,*7,"NO PHARMACY INFORMATION" Q
I '$O(^PS(55,+Y,"P",0)),$D(^PS(55,+Y,"ARC")) D ^PSODEM W !!,"PATIENT HAS ARCHIVED PRESCRIPTIONS",! Q
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") K DIR
K DIR G:PSRT="DATE" DEV S DIR("A")="PROFILE EXP/CANCEL CUTOFF",DIR("B")=45,DIR(0)="N^1:9999:0",DIR("?",1)="Enter the number of days which will cut canceled 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 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^MCPSOP" F G="PSODTCT","FN","DFN","DA","D0","PLS","PSRT","PSOPAR" S:$D(@G) ZTSAVE(G)=""
I K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Task Queued to Print",! K Q,ZTSK D Q G Q
D P,Q G Q
P K ^TMP($J) D LOOP Q:'$D(^TMP($J)) D ^PSODEM W:$O(^PS(55,DA,"ARC",0)) !!,"PATIENT HAS ARCHIVED PRESCRIPTIONS",!
I $Y+8>IOSL,$E(IOST,1,2)="C-" W "ENTER '^' TO HALT:" R X:DTIME S:'$T X="^" G Q:X="^" W @IOF
I $P($G(^PS(59.7,1,40.1)),"^") W !,"Outpatient prescriptions are cancelled 72 hours after admission",!
I PLS="S" D ^PSOP1 G Q
W ! S DRUG="" F II=0:0 S DRUG=$O(^TMP($J,DRUG)) Q:DRUG=""!($D(DTOUT))!($D(DUOUT)) F J=0:0 S J=$O(^TMP($J,DRUG,J)) Q:'J D O I $Y+8>IOSL,$E(IOST,1,2)="C-" D DIR W @IOF Q:$D(DUOUT)!($D(DTOUT))
Q D ^%ZISC K 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 S:$D(ZTQUEUED) ZTREQ="@" Q
O S RX0=^(J),RX2=$S($D(^PSRX(J,2)):^(2),1:""),RX3=$S($D(^PSRX(J,3)):^(3),1:""),DRX="NOT ON FILE"
I $D(^PSDRUG(+$P(RX0,"^",6),0)) S DRX=$P(^(0),"^")
I $Y+10>IOSL,$E(IOST,1,2)="C-" D DIR W @IOF Q:$D(DUOUT)!($D(DTOUT))
W:$Y+10>IOSL&($E(IOST,1,2)'="C-") @IOF W !,"RX #: ",$P(RX0,"^"),!,DRX,?45,"SIG: ",$P(RX0,"^",10)
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)
S PHYS=$S($D(^VA(200,+$P(RX0,"^",4),0)):$P(^(0),"^"),1:"UNKNOWN")
W !?2,"PHYS: ",PHYS,?30,"CLERK: ",$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),")"
W !?2,"LAST FILLED: " S Y=$P(RX3,"^") W:Y $E(Y,4,5),"-",$E(Y,6,7),"-",$E(Y,2,3),?45,$S($P(RX2,"^",15):"Original Fill Returned to Stock",1:"")
S CT=0,REF=$P(RX0,"^",9) W !?2,"REFILLED:" F K=0:0 S K=$O(^PSRX(J,1,K)) Q:'K D
.W:CT=5!(CT=10) !?11 W " "_$E(^PSRX(J,1,K,0),4,5)_"-"_$E(^(0),6,7)_"-"_$E(^(0),2,3)_" ("_$P(^(0),"^",2)_")"_$S($P(^(0),"^",16):"(R)",1:"") S REF=REF-1,CT=CT+1 W:CT#5 ","
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) I $D(^PSRX(J,0)),$P($G(^PSRX(J,0)),"^",15)'=13 D @PSRT
Q
DATE S X=$P(^PSRX(J,0),"^",13),X=999999999-X,^TMP($J,X,J)=^(0)
Q
DRUG I $P($G(^PSRX(J,2)),"^",6)'<PSODTCT,$D(^PSDRUG(+$P(^(0),"^",6),0)) S ^TMP($J,$E($P(^(0),"^"),1,31),J)=^PSRX(J,0)
Q
CLSS I $P($G(^PSRX(J,2)),"^",6)'<PSODTCT,$D(^PSDRUG(+$P(^(0),"^",6),0)) S ^TMP($J,$S($P(^(0),"^",2)]"":$E($P(^(0),"^",2),1,31),1:"UNKNOWN"),J)=^PSRX(J,0)
Q
DIR K DTOUT,DUOUT,DIR S DIR("?")="Enter '^' to Halt or Press Return to Continue",DIR(0)="FO",DIR("A")="Enter ""^"" to Halt" D ^DIR Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCPSOP 4589 printed Dec 13, 2024@02:16:49 Page 2
MCPSOP ;WISC/DMA-PHARMACY PATIENT PROFILE (MEDICINE VERS) ;7/30/96 10:39
+1 ;;2.3;Medicine;;09/13/1996
+2 ;modified from pharmacy to quit after displaying for one pt.
+3 ;quit if not entered from rheumatology module
if '$DATA(MCRH)
QUIT
DOIT SET (FN,DFN,D0,DA)=+Y
IF '$DATA(^PS(55,+Y,"P"))
IF '$DATA(^("ARC"))
WRITE !?20,*7,"NO PHARMACY INFORMATION"
QUIT
+1 IF '$ORDER(^PS(55,+Y,"P",0))
IF $DATA(^PS(55,+Y,"ARC"))
DO ^PSODEM
WRITE !!,"PATIENT HAS ARCHIVED PRESCRIPTIONS",!
QUIT
+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")
KILL DIR
+2 KILL DIR
if PSRT="DATE"
GOTO DEV
SET DIR("A")="PROFILE EXP/CANCEL CUTOFF"
SET DIR("B")=45
SET DIR(0)="N^1:9999:0"
SET DIR("?",1)="Enter the number of days which will cut canceled and expired Rx's from"
SET DIR("?")="the profile."
+3 DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO Q
KILL DIR
SET X1=DT
SET X2=-X
DO C^%DTC
SET PSODTCT=X
DEV 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
+1 KILL PSOION
IF $DATA(IO("Q"))
SET ZTDESC="PATIENT MEDICATION PROFILE"
SET ZTRTN="P^MCPSOP"
FOR G="PSODTCT","FN","DFN","DA","D0","PLS","PSRT","PSOPAR"
if $DATA(@G)
SET ZTSAVE(G)=""
+2 IF $TEST
KILL IO("Q")
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Task Queued to Print",!
KILL Q,ZTSK
DO Q
GOTO Q
+3 DO P
DO Q
GOTO Q
P KILL ^TMP($JOB)
DO LOOP
if '$DATA(^TMP($JOB))
QUIT
DO ^PSODEM
if $ORDER(^PS(55,DA,"ARC",0))
WRITE !!,"PATIENT HAS ARCHIVED PRESCRIPTIONS",!
+1 IF $Y+8>IOSL
IF $EXTRACT(IOST,1,2)="C-"
WRITE "ENTER '^' TO HALT:"
READ X:DTIME
if '$TEST
SET X="^"
if X="^"
GOTO Q
WRITE @IOF
+2 IF $PIECE($GET(^PS(59.7,1,40.1)),"^")
WRITE !,"Outpatient prescriptions are cancelled 72 hours after admission",!
+3 IF PLS="S"
DO ^PSOP1
GOTO Q
+4 WRITE !
SET DRUG=""
FOR II=0:0
SET DRUG=$ORDER(^TMP($JOB,DRUG))
if DRUG=""!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
FOR J=0:0
SET J=$ORDER(^TMP($JOB,DRUG,J))
if 'J
QUIT
DO O
IF $Y+8>IOSL
IF $EXTRACT(IOST,1,2)="C-"
DO DIR
WRITE @IOF
if $DATA(DUOUT)!($DATA(DTOUT))
QUIT
Q DO ^%ZISC
KILL 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
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
O SET RX0=^(J)
SET RX2=$SELECT($DATA(^PSRX(J,2)):^(2),1:"")
SET RX3=$SELECT($DATA(^PSRX(J,3)):^(3),1:"")
SET DRX="NOT ON FILE"
+1 IF $DATA(^PSDRUG(+$PIECE(RX0,"^",6),0))
SET DRX=$PIECE(^(0),"^")
+2 IF $Y+10>IOSL
IF $EXTRACT(IOST,1,2)="C-"
DO DIR
WRITE @IOF
if $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+3 if $Y+10>IOSL&($EXTRACT(IOST,1,2)'="C-")
WRITE @IOF
WRITE !,"RX #: ",$PIECE(RX0,"^"),!,DRX,?45,"SIG: ",$PIECE(RX0,"^",10)
+4 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)
+5 SET PHYS=$SELECT($DATA(^VA(200,+$PIECE(RX0,"^",4),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
+6 WRITE !?2,"PHYS: ",PHYS,?30,"CLERK: ",$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),")"
+7 WRITE !?2,"LAST FILLED: "
SET Y=$PIECE(RX3,"^")
if Y
WRITE $EXTRACT(Y,4,5),"-",$EXTRACT(Y,6,7),"-",$EXTRACT(Y,2,3),?45,$SELECT($PIECE(RX2,"^",15):"Original Fill Returned to Stock",1:"")
+8 SET CT=0
SET REF=$PIECE(RX0,"^",9)
WRITE !?2,"REFILLED:"
FOR K=0:0
SET K=$ORDER(^PSRX(J,1,K))
if 'K
QUIT
Begin DoDot:1
+9 if CT=5!(CT=10)
WRITE !?11
WRITE " "_$EXTRACT(^PSRX(J,1,K,0),4,5)_"-"_$EXTRACT(^(0),6,7)_"-"_$EXTRACT(^(0),2,3)_" ("_$PIECE(^(0),"^",2)_")"_$SELECT($PIECE(^(0),"^",16):"(R)",1:"")
SET REF=REF-1
SET CT=CT+1
if CT#5
WRITE ","
End DoDot:1
+10 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:"")_", "
+11 if $PIECE(RX3,"^",7)]""
WRITE !?2,"REMARKS: ",$PIECE(RX3,"^",7)
DO STAT^PSOFUNC
+12 SET PSDIV=$SELECT($DATA(^PS(59,+$PIECE(RX2,"^",9),0)):$PIECE(^(0),"^")_" ("_$PIECE(^(0),"^",6)_")",1:"UNKNOWN")
+13 WRITE !?2,"DIVISION: ",$EXTRACT(PSDIV,1,25),?40,ST,?60,REF," REFILL",$SELECT(REF'=1:"S",1:"")," LEFT",!
+14 QUIT
LOOP FOR I=0:0
SET I=$ORDER(^PS(55,DFN,"P",I))
if 'I
QUIT
SET J=+^(I,0)
IF $DATA(^PSRX(J,0))
IF $PIECE($GET(^PSRX(J,0)),"^",15)'=13
DO @PSRT
+1 QUIT
DATE SET X=$PIECE(^PSRX(J,0),"^",13)
SET X=999999999-X
SET ^TMP($JOB,X,J)=^(0)
+1 QUIT
DRUG IF $PIECE($GET(^PSRX(J,2)),"^",6)'<PSODTCT
IF $DATA(^PSDRUG(+$PIECE(^(0),"^",6),0))
SET ^TMP($JOB,$EXTRACT($PIECE(^(0),"^"),1,31),J)=^PSRX(J,0)
+1 QUIT
CLSS IF $PIECE($GET(^PSRX(J,2)),"^",6)'<PSODTCT
IF $DATA(^PSDRUG(+$PIECE(^(0),"^",6),0))
SET ^TMP($JOB,$SELECT($PIECE(^(0),"^",2)]"":$EXTRACT($PIECE(^(0),"^",2),1,31),1:"UNKNOWN"),J)=^PSRX(J,0)
+1 QUIT
DIR KILL DTOUT,DUOUT,DIR
SET DIR("?")="Enter '^' to Halt or Press Return to Continue"
SET DIR(0)="FO"
SET DIR("A")="Enter ""^"" to Halt"
DO ^DIR
QUIT
