APSPMED ; IHS/DSD/ENM - PRINTS PATIENT MEDICATION PROFILE LONG OR SHORT ; [ 09/03/97 1:30 PM ]
;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97
;This routine is a modified version of PSOP that calls APSPMED1
EP ;
W !,"Outpatient Pharmacy Medication Profile",!
D EP1^APSPMED1
I '$D(APSPDPT) D Q Q
;K ^TMP($J),ZTSK D DT^DICRW S DIC=2,DIC(0)="QEAM" D ^DIC G Q:Y<0 S (FN,DFN,D0,DA)=+Y I '$D(^PS(55,+Y,"P")),'$D(^("ARC")) W !?20,*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",! D ^PSODEM G PSOP
K ^TMP($J),ZTSK S APSPAGE=0,DA=0
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"
S ZTRTN="P^APSPMED" F APSPZZ="PSODTCT","FN","DFN","DA","D0","PLS","PSRT","PSOPAR","APSPAGE","APSPBD","APSPED" S ZTSAVE(APSPZZ)="" D
.F S APSP=$O(APSPDPT(APSP)) Q:'APSP S ZTSAVE("APSPDPT("_APSP_")")=""
I K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Task Queued to Print",! K Q,ZTSK D Q G APSPMED
D P,Q G APSPMED
P ;
S APSPZ=0 F S APSPZ=$O(APSPDPT(APSPZ)) Q:'APSPZ!($D(DTOUT))!($D(DUOUT))!($D(DIROUT)) S (FN,DFN,DO,DA)=APSPZ D PQ S APSPAGE=0 ;IHS/DSD/ENM 02/20/97
D Q Q
PQ K ^TMP($J) D LOOP Q:'$D(^TMP($J)) D ^APSPMED2 W:$O(^PS(55,DA,"ARC",0)) !!,"PATIENT HAS ARCHIVED PRESCRIPTIONS",!
I $D(^DPT(DA,.1)),^(.1)]"",$P($G(PSOPAR),"^",8) W !,"Outpatient prescriptions are cancelled 72 hours after admission",!
I PLS="S" D ^APSPMED3,PAUS Q ;IHS/DSD/ENM 02/20/97
W ! S DRUG="" F II=0:0 S DRUG=$O(^TMP($J,DRUG)) Q:DRUG="" F J=0:0 S J=$O(^TMP($J,DRUG,J)) Q:'J!($D(DTOUT))!($D(DUOUT))!($D(DIROUT)) D O
Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))
D PAUS ;IHS/DSD/ENM 02/20/97
Q
Q D ^%ZISC K ^TMP($J),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
K VA,VADM,VAEL,VAERR,VAPA,APSPDPT,APSPZ,APSPAGE,APSPBD,APSPED,APSP,ZTRTN,ZTSAVE,APSPCN S:$D(ZTQUEUED) ZTREQ="@" Q
O S RX0=^PSRX(J,0),RX2=$S($D(^PSRX(J,2)):^(2),1:""),DRX="NOT ON FILE" I $D(^PSDRUG(+$P(RX0,"^",6),0)) S DRX=$P(^(0),"^") ;IHS/DSD/ENM 052996
I $Y+4>IOSL,IOST["C-" S DIR("A")="ENTER '^' TO HALT",DIR(0)="E" D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT)) W @IOF D HDR^APSPMED2 ;IHS/DSD/ENM 02/19/97
I $Y+4>IOSL,IOST["P-" W @IOF D HDR^APSPMED2 ;IHS/DSD/ENM 02/19/97
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(^PSRX(J,2),"^",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(^PSRX(J,3),"^") 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):" Returned to Stock",1:"")_", "
W:$P(RX0,"^",12)]"" !?2,"REMARKS: ",$P(RX0,"^",12) 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,$P($G(^(0)),U,13)'<APSPBD&($P($G(^(0)),U,13)'>APSPED) D @PSRT
Q
DATE S X=$P(^PSRX(J,0),"^",13),X=99999999-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
PAUS I IOST["C-" S DIR("A")="ENTER '^' TO HALT",DIR(0)="E" D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT)) W @IOF ;IHS/DSD/ENM 02/19/97
Q
APSPMED ; IHS/DSD/ENM - PRINTS PATIENT MEDICATION PROFILE LONG OR SHORT ; [ 09/03/97 1:30 PM ]
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97
+2 ;This routine is a modified version of PSOP that calls APSPMED1
EP ;
+1 WRITE !,"Outpatient Pharmacy Medication Profile",!
+2 DO EP1^APSPMED1
+3 IF '$DATA(APSPDPT)
DO Q
QUIT
+4 ;K ^TMP($J),ZTSK D DT^DICRW S DIC=2,DIC(0)="QEAM" D ^DIC G Q:Y<0 S (FN,DFN,D0,DA)=+Y I '$D(^PS(55,+Y,"P")),'$D(^("ARC")) W !?20,*7,"NO PHARMACY INFORMATION" H 5 D ^PSODEM G PSOP
+5 ;I '$O(^PS(55,+Y,"P",0)),$D(^PS(55,+Y,"ARC")) D ^PSODEM W !!,"PATIENT HAS ARCHIVED PRESCRIPTIONS",! D ^PSODEM G PSOP
+6 KILL ^TMP($JOB),ZTSK
SET APSPAGE=0
SET DA=0
+7 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"
+2 SET ZTRTN="P^APSPMED"
FOR APSPZZ="PSODTCT","FN","DFN","DA","D0","PLS","PSRT","PSOPAR","APSPAGE","APSPBD","APSPED"
SET ZTSAVE(APSPZZ)=""
Begin DoDot:1
+3 FOR
SET APSP=$ORDER(APSPDPT(APSP))
IF 'APSP
QUIT
SET ZTSAVE("APSPDPT("_APSP_")")=""
End DoDot:1
+4 IF $TEST
KILL IO("Q")
DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !,"Task Queued to Print",!
KILL Q,ZTSK
DO Q
GOTO APSPMED
+5 DO P
DO Q
GOTO APSPMED
P ;
+1 ;IHS/DSD/ENM 02/20/97
SET APSPZ=0
FOR
SET APSPZ=$ORDER(APSPDPT(APSPZ))
IF 'APSPZ!($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
SET (FN,DFN,DO,DA)=APSPZ
DO PQ
SET APSPAGE=0
+2 DO Q
QUIT
PQ KILL ^TMP($JOB)
DO LOOP
IF '$DATA(^TMP($JOB))
QUIT
DO ^APSPMED2
IF $ORDER(^PS(55,DA,"ARC",0))
WRITE !!,"PATIENT HAS ARCHIVED PRESCRIPTIONS",!
+1 IF $DATA(^DPT(DA,.1))
IF ^(.1)]""
IF $PIECE($GET(PSOPAR),"^",8)
WRITE !,"Outpatient prescriptions are cancelled 72 hours after admission",!
+2 ;IHS/DSD/ENM 02/20/97
IF PLS="S"
DO ^APSPMED3
DO PAUS
QUIT
+3 WRITE !
SET DRUG=""
FOR II=0:0
SET DRUG=$ORDER(^TMP($JOB,DRUG))
IF DRUG=""
QUIT
FOR J=0:0
SET J=$ORDER(^TMP($JOB,DRUG,J))
IF 'J!($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
DO O
+4 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
+5 ;IHS/DSD/ENM 02/20/97
DO PAUS
+6 QUIT
Q DO ^%ZISC
KILL ^TMP($JOB),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
+1 KILL VA,VADM,VAEL,VAERR,VAPA,APSPDPT,APSPZ,APSPAGE,APSPBD,APSPED,APSP,ZTRTN,ZTSAVE,APSPCN
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
O ;IHS/DSD/ENM 052996
SET RX0=^PSRX(J,0)
SET RX2=$SELECT($DATA(^PSRX(J,2)):^(2),1:"")
SET DRX="NOT ON FILE"
IF $DATA(^PSDRUG(+$PIECE(RX0,"^",6),0))
SET DRX=$PIECE(^(0),"^")
+1 ;IHS/DSD/ENM 02/19/97
IF $Y+4>IOSL
IF IOST["C-"
SET DIR("A")="ENTER '^' TO HALT"
SET DIR(0)="E"
DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
WRITE @IOF
DO HDR^APSPMED2
+2 ;IHS/DSD/ENM 02/19/97
IF $Y+4>IOSL
IF IOST["P-"
WRITE @IOF
DO HDR^APSPMED2
+3 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(^PSRX(J,2),"^",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(^PSRX(J,3),"^")
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):" Returned to Stock",1:"")_", "
+11 IF $PIECE(RX0,"^",12)]""
WRITE !?2,"REMARKS: ",$PIECE(RX0,"^",12)
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
IF $PIECE($GET(^(0)),U,13)'<APSPBD&($PIECE($GET(^(0)),U,13)'>APSPED)
DO @PSRT
+1 QUIT
DATE SET X=$PIECE(^PSRX(J,0),"^",13)
SET X=99999999-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
PAUS ;IHS/DSD/ENM 02/19/97
IF IOST["C-"
SET DIR("A")="ENTER '^' TO HALT"
SET DIR(0)="E"
DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
WRITE @IOF
+1 QUIT
