- PSOP1 ;BHAM ISC/SAB - prints short medication profile ;May 20, 2020@10:41:46
- ;;7.0;OUTPATIENT PHARMACY;**15,46,103,132,148,233,326,251,313,441**;DEC 1997;Build 208
- ;External reference to ^PSDRUG supported by DBIA 221
- ;External reference to ^PS(50.605 supported by DBIA 696
- K RX,DTOUT,DIRUT,DIROUT,DUOUT
- D HD S DRUG="" F I=0:0 S DRUG=$O(^TMP($J,DRUG)) Q:DRUG=""!($G(PQT)) D G:$D(DTOUT)!($D(DUOUT))!($D(DIROUT)) Q
- .F J=0:0 S J=$O(^TMP($J,DRUG,J)) Q:'J!($G(PQT)) S RX0=^(J),RX2=$G(^PSRX(J,2)),$P(RX0,"^",15)=$G(^("STA")),CP=$S(+$G(^PSRX(J,"IB")):"$",1:" ") S:$P(RX2,"^",15)&($P(RX2,"^",2)) RST($P(RX2,"^",2))=1 S:$P(RX0,"^",15)="" $P(RX0,"^",15)=-1 D W
- D:'$G(PQT) PEND^PSOP2,NVA^PSOP2
- Q D ^%ZISC K ^TMP($J),PQT,PSODTCT,ST,D0,DIC,DIR,DIRUT,DUOUT,G,II,K,RXD,RXF,ZX,DRUG,X,DFN,PHYS,PSRT,CT,AL,I1,PLS,REF
- K LMI,PI,FN,Y,I,J,RX,DRX,ST,RX0,RX2,DA,PPPSTAT,PPP,EEEE,PPPCNT,PENDREX,PSOPEND,PPDIS,PPOI,PCOUNT,PP,FSIG,ZZZZ,INS1,MIG,SG,SIG,SIGOK
- S:$D(ZTQUEUED) ZTREQ="@"
- Q
- W I $Y+6>IOSL,$E(IOST)="C" D DIR W @IOF Q:$D(PQT) D HD
- N PSOBADR
- U IO I IO'=IO(0),$Y+6>IOSL W @IOF D HD
- I $E(IOST)'="C",$Y+6>IOSL W @IOF D HD
- D STAT^PSOFUNC S STA="A^N^R^H^N^S^^^^^^E^DC^^DP^DE^PH",ST=$P(STA,"^",(ST0+1)) K STA
- I ST="A" I $G(^PSRX(J,"PARK")) S ST="AP" ;441 PAPI
- S PSOBADR=$O(^PSRX(J,"L",9999),-1)
- I PSOBADR'="" S PSOBADR=$G(^PSRX(J,"L",PSOBADR,0)) I PSOBADR["(BAD ADDRESS)" S PSOBADR="B"
- I PSOBADR'="B" S PSOBADR=""
- S ST=ST_PSOBADR
- W !,CP_$P(RX0,"^"),$$ECME^PSOBPSUT(J),$$TITRX^PSOUTL(J),?14,$S($D(^PSDRUG(+$P(RX0,"^",6),0)):$E($P(^(0),"^"),1,39),1:"NOT ON FILE"),?54,$S($L(ST)=1:" "_ST,1:ST)
- S RXD=$P($G(^PSRX(J,3)),"^"),RXF=$P(RX0,"^",9) F II=0:0 S II=$O(^PSRX(J,1,II)) Q:'II S RXF=RXF-1 S:$P(^PSRX(J,1,II,0),"^",16) RST($P(^(0),"^"))=1
- W ?58,$S($L(RXF)=1:" "_RXF,1:RXF)
- W ?61,$E($P(RX0,"^",13),4,5)_"-"_$E($P(RX0,"^",13),6,7)_"-"_$E($P(RX0,"^",13),2,3) W:RXD ?70,$E(RXD,4,5)_"-"_$E(RXD,6,7)_"-"_$E(RXD,2,3)_$S($G(RST(RXD)):"R",1:"")
- S PSOPRSIG=$P($G(^PSRX(J,"SIG")),"^",2) K FSIG,BSIG D
- .I PSOPRSIG D FSIG^PSOUTLA("R",J,50) Q
- .D EN2^PSOUTLA1(J,50) F GGGG=0:0 S GGGG=$O(BSIG(GGGG)) Q:'GGGG S FSIG(GGGG)=BSIG(GGGG)
- K PSOPRSIG,GGGG,BSIG
- W !?5,"QTY: ",$P(RX0,"^",7),?24,"SIG: ",$G(FSIG(1)) D:$O(FSIG(1))
- .F GGGG=1:0 S GGGG=$O(FSIG(GGGG)) Q:'GGGG!($G(PQT)) W !,?29,$G(FSIG(GGGG)) D:$Y+5>IOSL&($E(IOST)="C") DIR Q:$G(PQT) I '$G(PQT),($Y+5>IOSL) W @IOF D HD
- W:$P($G(^PSRX(J,"IND")),"^")]"" !,?5,"Indication: "_$P(^PSRX(J,"IND"),"^") ;*441-IND
- K GGGG,FSIG Q:$G(PQT)
- ;D SIG
- K RST Q
- HD D:PAGE>1
- .W !,"Patient: "_$P(^DPT(DFN,0),"^")_" ("_$E($P(^DPT(DFN,0),"^",9),6,9)_")",?70,"Page: "_PAGE
- .W !?(80-$L("Medication Profile Sorted by "_HDR))/2,"Medication Profile Sorted by "_HDR W:$G(FR)]"" !?(80-$L(FR_" to "_TO))/2,FR_" to "_TO
- W !?57,"REF",!?1,"Rx#",?14,"Drug",?54,"ST",?57,"REM",?62,"Issued",?70,"Last Fill",!,PSOPLINE S PAGE=PAGE+1
- Q
- SORT K DIR,DUOUT,DTOUT
- S DIR("B")="All",DIR("A",1)=" ",DIR("A")="All Medications or Selection (A/S): ",DIR(0)="SAM^A:All;S:Select Range",DIR("?",1)="Enter 'A' to Print Entire Medication Profile",DIR("?")=" or 'S' for Selection Range" D ^DIR
- K DIR Q:$D(DIRUT)!(Y="A")!(Y="E") D @PSRT
- Q
- DATE ;asks date range
- W ! K %DT S %DT="AEX",%DT("A")="Starting Date: " D ^%DT I "^"[X S DUOUT=1 Q
- G:Y<0 DATE S SDT=+Y,%DT(0)=SDT,FR=$E(SDT,4,5)_"/"_$E(SDT,6,7)_"/"_$E(SDT,2,3)
- EDT S %DT("A")="Ending Date: " D ^%DT I "^"[X S DUOUT=1 Q
- G:Y<0 EDT S EDT=+Y,DTS=1,TO=$E(EDT,4,5)_"/"_$E(EDT,6,7)_"/"_$E(EDT,2,3)
- K %DT Q
- DRUG ;asks drug list
- W ! S DIC("A")="Start with Drug: ",DIC(0)="AEMQ",DIC=50
- S DIC("S")="I $S('$D(^PSDRUG(Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$S('$D(^PSDRUG(Y,2)):1,$P(^(2),""^"",3)'[""O"":0,1:1)"
- D ^DIC I "^"[X S DUOUT=1 K DIC Q
- G:Y<0 DRUG S FR=$P(Y,"^",2)
- F %=$L($E(FR,1,30)):-1:1 S M=$A(FR,%) I M>32 S Y1=$E(FR,1,%-1)_$C(M-1)_$C(122) Q
- S PSFR=Y1 K Y1,Y,X
- TO S DIC("A")="To Drug: " D ^DIC I "^"[X S DUOUT=1 K DIC Q
- G:Y<0 TO I FR]$P(Y,"^",2) W !,$C(7),"Less Than 'Start' Value" K X,Y G TO
- S TO=$P(Y,"^",2),DRS=1
- F %=$L($E(TO,1,30)):-1:1 S M=$A(TO,%) I M>32 S Y1=$E(TO,1,%-1)_$C(M+1)_$C(122) Q
- S PSTO=Y1 K Y1,Y,X,DIC,M,%
- Q
- CLSS ;asks drug class list
- W ! S DIC("A")="Start with Drug Class: ",DIC(0)="AEQ",DIC=50.605 D ^DIC I "^"[X S DUOUT=1 Q
- G:Y<0 CLSS S FR=$P(Y,"^",2)
- F %=$L($E(FR,1,30)):-1:1 S M=$A(FR,%) I M>32 S Y1=$E(FR,1,%-1)_$C(M-1)_$C(122) Q
- S PSFR=Y1 K Y1,Y,X
- TO1 S DIC("A")="To Drug Class: " D ^DIC I "^"[X S DUOUT=1 Q
- G:Y<0 TO1 I FR]$P(Y,"^",2) W !,$C(7),"Less Than 'Start' Value" K X,Y G TO1
- S TO=$P(Y,"^",2)
- F %=$L($E(TO,1,30)):-1:1 S M=$A(TO,%) I M>32 S Y1=$E(TO,1,%-1)_$C(M+1)_$C(122) Q
- S PSTO=Y1,CLS=1 K Y,Y1,X
- Q
- DIR K PQT,DTOUT,DUOUT,DIR,DIRUT S DIR(0)="E" D ^DIR S:$D(DUOUT)!($D(DTOUT)) PQT=1 Q
- SIG I '$P(^PSRX(J,"SIG"),"^",2) D Q
- .S X=$P(^PSRX(J,"SIG"),"^") D SIGONE^PSOHELP S SIG=$E($G(INS1),2,250)
- .F SG=1:1:$L(SIG) W:($X+$L($P(SIG," ",SG)_" "))>$S(IOST["C-":IOM,1:70) !?6 W:$P(SIG," ",SG)]"" $P(SIG," ",SG)_" "
- S MIG=$P(^PSRX(J,"SIG"),"^"),SIGOK=1 D
- .F SG=1:1:$L(MIG) Q:$P(MIG," ",SG)="" W:($X+$L($P(MIG," ",SG)_" "))>$S(IOST["C-":IOM,1:70) !?6 W $P(MIG," ",SG)_" "
- F I=0:0 S I=$O(^PSRX(RXN,"SIG1",I)) Q:'I S MIG=$P(^PSRX(RXN,"SIG1",I,0),"^") D
- .F SG=1:1:$L(MIG) Q:$P(MIG," ",SG)="" W:($X+$L($P(MIG," ",SG)_" "))>$S(IOST["C-":IOM,1:70) !?6 W $P(MIG," ",SG)_" "
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOP1 5369 printed Jan 18, 2025@03:33:38 Page 2
- PSOP1 ;BHAM ISC/SAB - prints short medication profile ;May 20, 2020@10:41:46
- +1 ;;7.0;OUTPATIENT PHARMACY;**15,46,103,132,148,233,326,251,313,441**;DEC 1997;Build 208
- +2 ;External reference to ^PSDRUG supported by DBIA 221
- +3 ;External reference to ^PS(50.605 supported by DBIA 696
- +4 KILL RX,DTOUT,DIRUT,DIROUT,DUOUT
- +5 DO HD
- SET DRUG=""
- FOR I=0:0
- SET DRUG=$ORDER(^TMP($JOB,DRUG))
- if DRUG=""!($GET(PQT))
- QUIT
- Begin DoDot:1
- +6 FOR J=0:0
- SET J=$ORDER(^TMP($JOB,DRUG,J))
- if 'J!($GET(PQT))
- QUIT
- SET RX0=^(J)
- SET RX2=$GET(^PSRX(J,2))
- SET $PIECE(RX0,"^",15)=$GET(^("STA"))
- SET CP=$SELECT(+$GET(^PSRX(J,"IB")):"$",1:" ")
- if $PIECE(RX2,"^",15)&($PIECE(RX2,"^",2))
- SET RST($PIECE(RX2,"^",2))=1
- if $PIECE(RX0,"^",15)=""
- SET $PIECE(RX0,"^",15)=-1
- DO W
- End DoDot:1
- if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
- GOTO Q
- +7 if '$GET(PQT)
- DO PEND^PSOP2
- DO NVA^PSOP2
- Q DO ^%ZISC
- KILL ^TMP($JOB),PQT,PSODTCT,ST,D0,DIC,DIR,DIRUT,DUOUT,G,II,K,RXD,RXF,ZX,DRUG,X,DFN,PHYS,PSRT,CT,AL,I1,PLS,REF
- +1 KILL LMI,PI,FN,Y,I,J,RX,DRX,ST,RX0,RX2,DA,PPPSTAT,PPP,EEEE,PPPCNT,PENDREX,PSOPEND,PPDIS,PPOI,PCOUNT,PP,FSIG,ZZZZ,INS1,MIG,SG,SIG,SIGOK
- +2 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +3 QUIT
- W IF $Y+6>IOSL
- IF $EXTRACT(IOST)="C"
- DO DIR
- WRITE @IOF
- if $DATA(PQT)
- QUIT
- DO HD
- +1 NEW PSOBADR
- +2 USE IO
- IF IO'=IO(0)
- IF $Y+6>IOSL
- WRITE @IOF
- DO HD
- +3 IF $EXTRACT(IOST)'="C"
- IF $Y+6>IOSL
- WRITE @IOF
- DO HD
- +4 DO STAT^PSOFUNC
- SET STA="A^N^R^H^N^S^^^^^^E^DC^^DP^DE^PH"
- SET ST=$PIECE(STA,"^",(ST0+1))
- KILL STA
- +5 ;441 PAPI
- IF ST="A"
- IF $GET(^PSRX(J,"PARK"))
- SET ST="AP"
- +6 SET PSOBADR=$ORDER(^PSRX(J,"L",9999),-1)
- +7 IF PSOBADR'=""
- SET PSOBADR=$GET(^PSRX(J,"L",PSOBADR,0))
- IF PSOBADR["(BAD ADDRESS)"
- SET PSOBADR="B"
- +8 IF PSOBADR'="B"
- SET PSOBADR=""
- +9 SET ST=ST_PSOBADR
- +10 WRITE !,CP_$PIECE(RX0,"^"),$$ECME^PSOBPSUT(J),$$TITRX^PSOUTL(J),?14,$SELECT($DATA(^PSDRUG(+$PIECE(RX0,"^",6),0)):$EXTRACT($PIECE(^(0),"^"),1,39),1:"NOT ON FILE"),?54,$SELECT($LENGTH(ST)=1:" "_ST,1:ST)
- +11 SET RXD=$PIECE($GET(^PSRX(J,3)),"^")
- SET RXF=$PIECE(RX0,"^",9)
- FOR II=0:0
- SET II=$ORDER(^PSRX(J,1,II))
- if 'II
- QUIT
- SET RXF=RXF-1
- if $PIECE(^PSRX(J,1,II,0),"^",16)
- SET RST($PIECE(^(0),"^"))=1
- +12 WRITE ?58,$SELECT($LENGTH(RXF)=1:" "_RXF,1:RXF)
- +13 WRITE ?61,$EXTRACT($PIECE(RX0,"^",13),4,5)_"-"_$EXTRACT($PIECE(RX0,"^",13),6,7)_"-"_$EXTRACT($PIECE(RX0,"^",13),2,3)
- if RXD
- WRITE ?70,$EXTRACT(RXD,4,5)_"-"_$EXTRACT(RXD,6,7)_"-"_$EXTRACT(RXD,2,3)_$SELECT($GET(RST(RXD)):"R",1:"")
- +14 SET PSOPRSIG=$PIECE($GET(^PSRX(J,"SIG")),"^",2)
- KILL FSIG,BSIG
- Begin DoDot:1
- +15 IF PSOPRSIG
- DO FSIG^PSOUTLA("R",J,50)
- QUIT
- +16 DO EN2^PSOUTLA1(J,50)
- FOR GGGG=0:0
- SET GGGG=$ORDER(BSIG(GGGG))
- if 'GGGG
- QUIT
- SET FSIG(GGGG)=BSIG(GGGG)
- End DoDot:1
- +17 KILL PSOPRSIG,GGGG,BSIG
- +18 WRITE !?5,"QTY: ",$PIECE(RX0,"^",7),?24,"SIG: ",$GET(FSIG(1))
- if $ORDER(FSIG(1))
- Begin DoDot:1
- +19 FOR GGGG=1:0
- SET GGGG=$ORDER(FSIG(GGGG))
- if 'GGGG!($GET(PQT))
- QUIT
- WRITE !,?29,$GET(FSIG(GGGG))
- if $Y+5>IOSL&($EXTRACT(IOST)="C")
- DO DIR
- if $GET(PQT)
- QUIT
- IF '$GET(PQT)
- IF ($Y+5>IOSL)
- WRITE @IOF
- DO HD
- End DoDot:1
- +20 ;*441-IND
- if $PIECE($GET(^PSRX(J,"IND")),"^")]""
- WRITE !,?5,"Indication: "_$PIECE(^PSRX(J,"IND"),"^")
- +21 KILL GGGG,FSIG
- if $GET(PQT)
- QUIT
- +22 ;D SIG
- +23 KILL RST
- QUIT
- HD if PAGE>1
- Begin DoDot:1
- +1 WRITE !,"Patient: "_$PIECE(^DPT(DFN,0),"^")_" ("_$EXTRACT($PIECE(^DPT(DFN,0),"^",9),6,9)_")",?70,"Page: "_PAGE
- +2 WRITE !?(80-$LENGTH("Medication Profile Sorted by "_HDR))/2,"Medication Profile Sorted by "_HDR
- if $GET(FR)]""
- WRITE !?(80-$LENGTH(FR_" to "_TO))/2,FR_" to "_TO
- End DoDot:1
- +3 WRITE !?57,"REF",!?1,"Rx#",?14,"Drug",?54,"ST",?57,"REM",?62,"Issued",?70,"Last Fill",!,PSOPLINE
- SET PAGE=PAGE+1
- +4 QUIT
- SORT KILL DIR,DUOUT,DTOUT
- +1 SET DIR("B")="All"
- SET DIR("A",1)=" "
- SET DIR("A")="All Medications or Selection (A/S): "
- SET DIR(0)="SAM^A:All;S:Select Range"
- SET DIR("?",1)="Enter 'A' to Print Entire Medication Profile"
- SET DIR("?")=" or 'S' for Selection Range"
- DO ^DIR
- +2 KILL DIR
- if $DATA(DIRUT)!(Y="A")!(Y="E")
- QUIT
- DO @PSRT
- +3 QUIT
- DATE ;asks date range
- +1 WRITE !
- KILL %DT
- SET %DT="AEX"
- SET %DT("A")="Starting Date: "
- DO ^%DT
- IF "^"[X
- SET DUOUT=1
- QUIT
- +2 if Y<0
- GOTO DATE
- SET SDT=+Y
- SET %DT(0)=SDT
- SET FR=$EXTRACT(SDT,4,5)_"/"_$EXTRACT(SDT,6,7)_"/"_$EXTRACT(SDT,2,3)
- EDT SET %DT("A")="Ending Date: "
- DO ^%DT
- IF "^"[X
- SET DUOUT=1
- QUIT
- +1 if Y<0
- GOTO EDT
- SET EDT=+Y
- SET DTS=1
- SET TO=$EXTRACT(EDT,4,5)_"/"_$EXTRACT(EDT,6,7)_"/"_$EXTRACT(EDT,2,3)
- +2 KILL %DT
- QUIT
- DRUG ;asks drug list
- +1 WRITE !
- SET DIC("A")="Start with Drug: "
- SET DIC(0)="AEMQ"
- SET DIC=50
- +2 SET DIC("S")="I $S('$D(^PSDRUG(Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0),$S('$D(^PSDRUG(Y,2)):1,$P(^(2),""^"",3)'[""O"":0,1:1)"
- +3 DO ^DIC
- IF "^"[X
- SET DUOUT=1
- KILL DIC
- QUIT
- +4 if Y<0
- GOTO DRUG
- SET FR=$PIECE(Y,"^",2)
- +5 FOR %=$LENGTH($EXTRACT(FR,1,30)):-1:1
- SET M=$ASCII(FR,%)
- IF M>32
- SET Y1=$EXTRACT(FR,1,%-1)_$CHAR(M-1)_$CHAR(122)
- QUIT
- +6 SET PSFR=Y1
- KILL Y1,Y,X
- TO SET DIC("A")="To Drug: "
- DO ^DIC
- IF "^"[X
- SET DUOUT=1
- KILL DIC
- QUIT
- +1 if Y<0
- GOTO TO
- IF FR]$PIECE(Y,"^",2)
- WRITE !,$CHAR(7),"Less Than 'Start' Value"
- KILL X,Y
- GOTO TO
- +2 SET TO=$PIECE(Y,"^",2)
- SET DRS=1
- +3 FOR %=$LENGTH($EXTRACT(TO,1,30)):-1:1
- SET M=$ASCII(TO,%)
- IF M>32
- SET Y1=$EXTRACT(TO,1,%-1)_$CHAR(M+1)_$CHAR(122)
- QUIT
- +4 SET PSTO=Y1
- KILL Y1,Y,X,DIC,M,%
- +5 QUIT
- CLSS ;asks drug class list
- +1 WRITE !
- SET DIC("A")="Start with Drug Class: "
- SET DIC(0)="AEQ"
- SET DIC=50.605
- DO ^DIC
- IF "^"[X
- SET DUOUT=1
- QUIT
- +2 if Y<0
- GOTO CLSS
- SET FR=$PIECE(Y,"^",2)
- +3 FOR %=$LENGTH($EXTRACT(FR,1,30)):-1:1
- SET M=$ASCII(FR,%)
- IF M>32
- SET Y1=$EXTRACT(FR,1,%-1)_$CHAR(M-1)_$CHAR(122)
- QUIT
- +4 SET PSFR=Y1
- KILL Y1,Y,X
- TO1 SET DIC("A")="To Drug Class: "
- DO ^DIC
- IF "^"[X
- SET DUOUT=1
- QUIT
- +1 if Y<0
- GOTO TO1
- IF FR]$PIECE(Y,"^",2)
- WRITE !,$CHAR(7),"Less Than 'Start' Value"
- KILL X,Y
- GOTO TO1
- +2 SET TO=$PIECE(Y,"^",2)
- +3 FOR %=$LENGTH($EXTRACT(TO,1,30)):-1:1
- SET M=$ASCII(TO,%)
- IF M>32
- SET Y1=$EXTRACT(TO,1,%-1)_$CHAR(M+1)_$CHAR(122)
- QUIT
- +4 SET PSTO=Y1
- SET CLS=1
- KILL Y,Y1,X
- +5 QUIT
- DIR KILL PQT,DTOUT,DUOUT,DIR,DIRUT
- SET DIR(0)="E"
- DO ^DIR
- if $DATA(DUOUT)!($DATA(DTOUT))
- SET PQT=1
- QUIT
- SIG IF '$PIECE(^PSRX(J,"SIG"),"^",2)
- Begin DoDot:1
- +1 SET X=$PIECE(^PSRX(J,"SIG"),"^")
- DO SIGONE^PSOHELP
- SET SIG=$EXTRACT($GET(INS1),2,250)
- +2 FOR SG=1:1:$LENGTH(SIG)
- if ($X+$LENGTH($PIECE(SIG," ",SG)_" "))>$SELECT(IOST["C-"
- WRITE !?6
- if $PIECE(SIG," ",SG)]""
- WRITE $PIECE(SIG," ",SG)_" "
- End DoDot:1
- QUIT
- +3 SET MIG=$PIECE(^PSRX(J,"SIG"),"^")
- SET SIGOK=1
- Begin DoDot:1
- +4 FOR SG=1:1:$LENGTH(MIG)
- if $PIECE(MIG," ",SG)=""
- QUIT
- if ($X+$LENGTH($PIECE(MIG," ",SG)_" "))>$SELECT(IOST["C-"
- WRITE !?6
- WRITE $PIECE(MIG," ",SG)_" "
- End DoDot:1
- +5 FOR I=0:0
- SET I=$ORDER(^PSRX(RXN,"SIG1",I))
- if 'I
- QUIT
- SET MIG=$PIECE(^PSRX(RXN,"SIG1",I,0),"^")
- Begin DoDot:1
- +6 FOR SG=1:1:$LENGTH(MIG)
- if $PIECE(MIG," ",SG)=""
- QUIT
- if ($X+$LENGTH($PIECE(MIG," ",SG)_" "))>$SELECT(IOST["C-"
- WRITE !?6
- WRITE $PIECE(MIG," ",SG)_" "
- End DoDot:1
- +7 QUIT