- 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 Feb 18, 2025@23:43:17 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