PSOLBLS ;BIR/LGH-LABEL FOR SUSPENDED SCRIPTS ;11/17/92 18:18
;;7.0;OUTPATIENT PHARMACY;**5,30**;DEC 1997
;External reference to ^DIC(5 supported by DBIA 10056
I '+$G(RXN) Q
AC S PSODFN=DFN,(SPPL,RXX,STA)=""
I $G(PSODTCUT)']"" S X1=DT,X2=-120 D C^%DTC S PSODTCUT=X
D ^PSOBUILD S (STA,RXX)=""
F S STA=$O(PSOSD(STA)) Q:STA="" F S RXX=$O(PSOSD(STA,RXX)) Q:RXX="" I $P(PSOSD(STA,RXX),"^",2)=5 S SPPL=$P(PSOSD(STA,RXX),"^")_","_SPPL
G:SPPL="" EXIT
D 6^VADPT,PID^VADPT
W ?54,$G(VA("PID")),!,?54,$P(^DPT(DFN,0),"^")
I '$P(^PS(59,PSOSITE,1),"^",28) S ADDR(3)=$G(VAPA(4))_", "_$P($G(VAPA(5)),"^",2)_" "_$S($G(VAPA(11))]"":$P($G(VAPA(11)),"^",2),1:$G(VAPA(6))),ADDR(2)="" S:$G(VAPA(2))]"" ADDR(2)=VAPA(2)_" "_VAPA(3) S:ADDR(2)="" ADDR(2)=ADDR(3),ADDR(3)=""
I '$P(^PS(59,PSOSITE,1),"^",28) W !,?54,$G(VAPA(1)),!,?54,$G(ADDR(2)),!,?54,$G(ADDR(3)),!
E W !,?54,$G(VAPA(1)),!,?54,$G(ADDR(2)) W:$G(ADDR(3))'="" !,?54,$G(ADDR(3)) W:$G(ADDR(4))'="" !,?54,$G(ADDR(4)) W !
W !,?54," The following prescriptions will be"
W !,?54,"mailed to you on or after the date indicated."
W !!,?54,"Rx# Date"
W !,?54,"============================================",!
F XX=1:1 Q:$P(SPPL,",",XX)="" S RX=$P(SPPL,",",XX) D
.S SPNUM=$O(^PS(52.5,"B",RX,0)) I SPNUM S SPDATE=$P($G(^PS(52.5,SPNUM,0)),"^",2) S Y=SPDATE D DD^%DT S SPDATE=Y
.W !,?54,$P(^PSRX(RX,0),"^"),?72," ",$G(SPDATE),!,?56,$$ZZ^PSOSUTL(RX) K SPNUM,SPDATE,Y,ZDRUG
W @IOF
EXIT K XX,RX,SPPL,RXX,SPPL,PSOSD,Y,SPNUM,SPDATE Q
Q
MAIL S PSOMSTOP=1,PSOMAILS=1,PS=$S($D(^PS(59,PSOSITE,0)):^(0),1:"") I $P(PSOSYS,"^",4),$D(^PS(59,+$P($G(PSOSYS),"^",4),0)) S PS=^PS(59,$P($G(PSOSYS),"^",4),0)
S VAADDR1=$P(PS,"^"),VASTREET=$P(PS,"^",2),STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UNKNOWN")
S PSZIP=$P(PS,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
K ^UTILITY($J,"W") S PSKNT=0,DIWL=55,DIWR=100,DIWF="" F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,6,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP
I '$D(^UTILITY($J,"W",DIWL)) S PSOMAILS=0 G MAILR
F AA=0:0 S AA=$O(^UTILITY($J,"W",DIWL,AA)) Q:'AA S PSKNT=PSKNT+1 W ?54,^(AA,0) W ! D CHECK
MAILR I $G(PSOMAILS) S PSKNT=PSKNT+1 W ! D CHECK
K ^UTILITY($J,"W") F ZZ=0:0 S ZZ=$O(^PS(59,PSOSITE,7,ZZ)) Q:'ZZ I $D(^(ZZ,0)) S X=^(0) D ^DIWP
I $D(^UTILITY($J,"W",DIWL)) F AA=0:0 S AA=$O(^UTILITY($J,"W",DIWL,AA)) Q:'AA S PSKNT=PSKNT+1 W ?54,^(AA,0) W ! D CHECK
I PSKNT>20 G REXIT
I PSKNT<4 W:PSKNT=0 !!!! W:PSKNT=1 !!! W:PSKNT=2 !! W:PSKNT=3 !
I PSKNT<4 W "Pharmacy Service (119)",!,$G(VAADDR1),!,$G(VASTREET),!,$P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP) W !!!!!!!!!!!! D PRINT G REXIT
I PSKNT=4 W ! W $G(VAADDR1),!,$G(VASTREET),!,$P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP) W !!!!!!!!!!!! D PRINT G REXIT
I PSKNT=5 W ! W $G(VASTREET),!,$P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP) W !!!!!!!!!!!! D PRINT G REXIT
I PSKNT=6 W ! W $P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP) W !!!!!!!!!!!! D PRINT G REXIT
I PSKNT=18 W ! W "Use the label above to mail the computer",!,"copies back to us. Apply enough postage",!,"to your envelope to ensure delivery." G REXIT
I PSKNT=19 W ! W "copies back to us. Apply enough postage",!,"to your envelope to ensure delivery." G REXIT
I PSKNT=20 W ! W "to your envelope to ensure delivery." G REXIT
S PSKNT=(20-PSKNT) F PP=1:1:PSKNT W !
W ! D PRINT
REXIT K ^UTILITY($J,"W"),PSKNT,PP,AA,ZZ,DIWL,DIWF,DIWR,PSOMSTOP,PSOMAILS,VAADDR1,VASTREET,STATE,PSZIP,PSOHZIP W @IOF Q
CHECK W:PSKNT=4 "Pharmacy Service (119)" W:PSKNT=5 $G(VAADDR1) W:PSKNT=6 $G(VASTREET) W:PSKNT=7 $P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP)
W:PSKNT=19 "Use the label above to mail the computer" W:PSKNT=20 "copies back to us. Apply enough postage" W:PSKNT=21 "to your envelope to ensure delivery."
Q
PRINT W "Use the label above to mail the computer",!,"copies back to us. Apply enough postage",!,"to your envelope to ensure delivery." Q
ALL ;PRINT ALLERGIES
I $G(PSOBLALL),$P(PPL,",",PI+1)'="" Q
X "N X S X=""GMRADPT"" X ^%ZOSF(""TEST"") Q" Q:'$T
S GMRA="0^0^111" D ^GMRADPT
K ^TMP($J,"ALL")
I $G(GMRAL) F PSORY=0:0 S PSORY=$O(GMRAL(PSORY)) Q:'PSORY S ^TMP($J,"ALL",$S($P(GMRAL(PSORY),"^",4):1,1:2),$S('$P(GMRAL(PSORY),"^",5):1,1:2),$P(GMRAL(PSORY),"^",7),$P(GMRAL(PSORY),"^",2))=""
W ?102,$G(PNM)," ",$G(SSNP),!!
W ?102,"Verified Allergies",!,?102,"------------------"
S III=0,(ALG,ALGR)="" F S ALG=$O(^TMP($J,"ALL",1,1,ALG)) Q:ALG="" F S ALGR=$O(^TMP($J,"ALL",1,1,ALG,ALGR)) Q:ALGR="" S III=1 W !,?104,ALGR
I III W !
I 'III W !,?104,$S($G(GMRAL)=0:"NKA",1:"") W:$G(GMRAL)=0 !
W !,?102,"Non-Verified Allergies",!,?102,"----------------------"
S III=0,(ALG,ALGR)="" F S ALG=$O(^TMP($J,"ALL",2,1,ALG)) Q:ALG="" F S ALGR=$O(^TMP($J,"ALL",2,1,ALG,ALGR)) Q:ALGR="" S III=1 W !,?104,ALGR
I III W !
I 'III W !,?104,$S($G(GMRAL)=0:"NKA",1:"") W:$G(GMRAL)=0 !
W !,?102,"Verified Adverse Reactions",!,?102,"--------------------------"
S (ALG,ALGR)="" F S ALG=$O(^TMP($J,"ALL",1,2,ALG)) Q:ALG="" F S ALGR=$O(^TMP($J,"ALL",1,2,ALG,ALGR)) Q:ALGR="" S III=1 W !,?104,ALGR
W !!,?102,"Non-Verified Adverse Reactions",!,?102,"------------------------------"
S (ALG,ALGR)="" F S ALG=$O(^TMP($J,"ALL",2,2,ALG)) Q:ALG="" F S ALGR=$O(^TMP($J,"ALL",2,2,ALG,ALGR)) Q:ALGR="" W !,?104,ALGR
K ^TMP($J,"ALL"),ALGR,PSORY,GMRA,GMRAL,ALG,III,JJJ W @IOF Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOLBLS 5409 printed Apr 09, 2024@21:31:59 Page 2
PSOLBLS ;BIR/LGH-LABEL FOR SUSPENDED SCRIPTS ;11/17/92 18:18
+1 ;;7.0;OUTPATIENT PHARMACY;**5,30**;DEC 1997
+2 ;External reference to ^DIC(5 supported by DBIA 10056
+3 IF '+$GET(RXN)
QUIT
AC SET PSODFN=DFN
SET (SPPL,RXX,STA)=""
+1 IF $GET(PSODTCUT)']""
SET X1=DT
SET X2=-120
DO C^%DTC
SET PSODTCUT=X
+2 DO ^PSOBUILD
SET (STA,RXX)=""
+3 FOR
SET STA=$ORDER(PSOSD(STA))
if STA=""
QUIT
FOR
SET RXX=$ORDER(PSOSD(STA,RXX))
if RXX=""
QUIT
IF $PIECE(PSOSD(STA,RXX),"^",2)=5
SET SPPL=$PIECE(PSOSD(STA,RXX),"^")_","_SPPL
+4 if SPPL=""
GOTO EXIT
+5 DO 6^VADPT
DO PID^VADPT
+6 WRITE ?54,$GET(VA("PID")),!,?54,$PIECE(^DPT(DFN,0),"^")
+7 IF '$PIECE(^PS(59,PSOSITE,1),"^",28)
SET ADDR(3)=$GET(VAPA(4))_", "_$PIECE($GET(VAPA(5)),"^",2)_" "_$SELECT($GET(VAPA(11))]"":$PIECE($GET(VAPA(11)),"^",2),1:$GET(VAPA(6)))
SET ADDR(2)=""
if $GET(VAPA(2))]""
SET ADDR(2)=VAPA(2)_" "_VAPA(3)
if ADDR(2)=""
SET ADDR(2)=ADDR(3)
SET ADDR(3)=""
+8 IF '$PIECE(^PS(59,PSOSITE,1),"^",28)
WRITE !,?54,$GET(VAPA(1)),!,?54,$GET(ADDR(2)),!,?54,$GET(ADDR(3)),!
+9 IF '$TEST
WRITE !,?54,$GET(VAPA(1)),!,?54,$GET(ADDR(2))
if $GET(ADDR(3))'=""
WRITE !,?54,$GET(ADDR(3))
if $GET(ADDR(4))'=""
WRITE !,?54,$GET(ADDR(4))
WRITE !
+10 WRITE !,?54," The following prescriptions will be"
+11 WRITE !,?54,"mailed to you on or after the date indicated."
+12 WRITE !!,?54,"Rx# Date"
+13 WRITE !,?54,"============================================",!
+14 FOR XX=1:1
if $PIECE(SPPL,",",XX)=""
QUIT
SET RX=$PIECE(SPPL,",",XX)
Begin DoDot:1
+15 SET SPNUM=$ORDER(^PS(52.5,"B",RX,0))
IF SPNUM
SET SPDATE=$PIECE($GET(^PS(52.5,SPNUM,0)),"^",2)
SET Y=SPDATE
DO DD^%DT
SET SPDATE=Y
+16 WRITE !,?54,$PIECE(^PSRX(RX,0),"^"),?72," ",$GET(SPDATE),!,?56,$$ZZ^PSOSUTL(RX)
KILL SPNUM,SPDATE,Y,ZDRUG
End DoDot:1
+17 WRITE @IOF
EXIT KILL XX,RX,SPPL,RXX,SPPL,PSOSD,Y,SPNUM,SPDATE
QUIT
+1 QUIT
MAIL SET PSOMSTOP=1
SET PSOMAILS=1
SET PS=$SELECT($DATA(^PS(59,PSOSITE,0)):^(0),1:"")
IF $PIECE(PSOSYS,"^",4)
IF $DATA(^PS(59,+$PIECE($GET(PSOSYS),"^",4),0))
SET PS=^PS(59,$PIECE($GET(PSOSYS),"^",4),0)
+1 SET VAADDR1=$PIECE(PS,"^")
SET VASTREET=$PIECE(PS,"^",2)
SET STATE=$SELECT($DATA(^DIC(5,+$PIECE(PS,"^",8),0)):$PIECE(^(0),"^",2),1:"UNKNOWN")
+2 SET PSZIP=$PIECE(PS,"^",5)
SET PSOHZIP=$SELECT(PSZIP["-":PSZIP,1:$EXTRACT(PSZIP,1,5)_$SELECT($EXTRACT(PSZIP,6,9)]"":"-"_$EXTRACT(PSZIP,6,9),1:""))
+3 KILL ^UTILITY($JOB,"W")
SET PSKNT=0
SET DIWL=55
SET DIWR=100
SET DIWF=""
FOR ZZ=0:0
SET ZZ=$ORDER(^PS(59,PSOSITE,6,ZZ))
if 'ZZ
QUIT
IF $DATA(^(ZZ,0))
SET X=^(0)
DO ^DIWP
+4 IF '$DATA(^UTILITY($JOB,"W",DIWL))
SET PSOMAILS=0
GOTO MAILR
+5 FOR AA=0:0
SET AA=$ORDER(^UTILITY($JOB,"W",DIWL,AA))
if 'AA
QUIT
SET PSKNT=PSKNT+1
WRITE ?54,^(AA,0)
WRITE !
DO CHECK
MAILR IF $GET(PSOMAILS)
SET PSKNT=PSKNT+1
WRITE !
DO CHECK
+1 KILL ^UTILITY($JOB,"W")
FOR ZZ=0:0
SET ZZ=$ORDER(^PS(59,PSOSITE,7,ZZ))
if 'ZZ
QUIT
IF $DATA(^(ZZ,0))
SET X=^(0)
DO ^DIWP
+2 IF $DATA(^UTILITY($JOB,"W",DIWL))
FOR AA=0:0
SET AA=$ORDER(^UTILITY($JOB,"W",DIWL,AA))
if 'AA
QUIT
SET PSKNT=PSKNT+1
WRITE ?54,^(AA,0)
WRITE !
DO CHECK
+3 IF PSKNT>20
GOTO REXIT
+4 IF PSKNT<4
if PSKNT=0
WRITE !!!!
if PSKNT=1
WRITE !!!
if PSKNT=2
WRITE !!
if PSKNT=3
WRITE !
+5 IF PSKNT<4
WRITE "Pharmacy Service (119)",!,$GET(VAADDR1),!,$GET(VASTREET),!,$PIECE(PS,"^",7)_", "_$GET(STATE)_" "_$GET(PSOHZIP)
WRITE !!!!!!!!!!!!
DO PRINT
GOTO REXIT
+6 IF PSKNT=4
WRITE !
WRITE $GET(VAADDR1),!,$GET(VASTREET),!,$PIECE(PS,"^",7)_", "_$GET(STATE)_" "_$GET(PSOHZIP)
WRITE !!!!!!!!!!!!
DO PRINT
GOTO REXIT
+7 IF PSKNT=5
WRITE !
WRITE $GET(VASTREET),!,$PIECE(PS,"^",7)_", "_$GET(STATE)_" "_$GET(PSOHZIP)
WRITE !!!!!!!!!!!!
DO PRINT
GOTO REXIT
+8 IF PSKNT=6
WRITE !
WRITE $PIECE(PS,"^",7)_", "_$GET(STATE)_" "_$GET(PSOHZIP)
WRITE !!!!!!!!!!!!
DO PRINT
GOTO REXIT
+9 IF PSKNT=18
WRITE !
WRITE "Use the label above to mail the computer",!,"copies back to us. Apply enough postage",!,"to your envelope to ensure delivery."
GOTO REXIT
+10 IF PSKNT=19
WRITE !
WRITE "copies back to us. Apply enough postage",!,"to your envelope to ensure delivery."
GOTO REXIT
+11 IF PSKNT=20
WRITE !
WRITE "to your envelope to ensure delivery."
GOTO REXIT
+12 SET PSKNT=(20-PSKNT)
FOR PP=1:1:PSKNT
WRITE !
+13 WRITE !
DO PRINT
REXIT KILL ^UTILITY($JOB,"W"),PSKNT,PP,AA,ZZ,DIWL,DIWF,DIWR,PSOMSTOP,PSOMAILS,VAADDR1,VASTREET,STATE,PSZIP,PSOHZIP
WRITE @IOF
QUIT
CHECK if PSKNT=4
WRITE "Pharmacy Service (119)"
if PSKNT=5
WRITE $GET(VAADDR1)
if PSKNT=6
WRITE $GET(VASTREET)
if PSKNT=7
WRITE $PIECE(PS,"^",7)_", "_$GET(STATE)_" "_$GET(PSOHZIP)
+1 if PSKNT=19
WRITE "Use the label above to mail the computer"
if PSKNT=20
WRITE "copies back to us. Apply enough postage"
if PSKNT=21
WRITE "to your envelope to ensure delivery."
+2 QUIT
PRINT WRITE "Use the label above to mail the computer",!,"copies back to us. Apply enough postage",!,"to your envelope to ensure delivery."
QUIT
ALL ;PRINT ALLERGIES
+1 IF $GET(PSOBLALL)
IF $PIECE(PPL,",",PI+1)'=""
QUIT
+2 XECUTE "N X S X=""GMRADPT"" X ^%ZOSF(""TEST"") Q"
if '$TEST
QUIT
+3 SET GMRA="0^0^111"
DO ^GMRADPT
+4 KILL ^TMP($JOB,"ALL")
+5 IF $GET(GMRAL)
FOR PSORY=0:0
SET PSORY=$ORDER(GMRAL(PSORY))
if 'PSORY
QUIT
SET ^TMP($JOB,"ALL",$SELECT($PIECE(GMRAL(PSORY),"^",4):1,1:2),$SELECT('$PIECE(GMRAL(PSORY),"^",5):1,1:2),$PIECE(GMRAL(PSORY),"^",7),$PIECE(GMRAL(PSORY),"^",2))=""
+6 WRITE ?102,$GET(PNM)," ",$GET(SSNP),!!
+7 WRITE ?102,"Verified Allergies",!,?102,"------------------"
+8 SET III=0
SET (ALG,ALGR)=""
FOR
SET ALG=$ORDER(^TMP($JOB,"ALL",1,1,ALG))
if ALG=""
QUIT
FOR
SET ALGR=$ORDER(^TMP($JOB,"ALL",1,1,ALG,ALGR))
if ALGR=""
QUIT
SET III=1
WRITE !,?104,ALGR
+9 IF III
WRITE !
+10 IF 'III
WRITE !,?104,$SELECT($GET(GMRAL)=0:"NKA",1:"")
if $GET(GMRAL)=0
WRITE !
+11 WRITE !,?102,"Non-Verified Allergies",!,?102,"----------------------"
+12 SET III=0
SET (ALG,ALGR)=""
FOR
SET ALG=$ORDER(^TMP($JOB,"ALL",2,1,ALG))
if ALG=""
QUIT
FOR
SET ALGR=$ORDER(^TMP($JOB,"ALL",2,1,ALG,ALGR))
if ALGR=""
QUIT
SET III=1
WRITE !,?104,ALGR
+13 IF III
WRITE !
+14 IF 'III
WRITE !,?104,$SELECT($GET(GMRAL)=0:"NKA",1:"")
if $GET(GMRAL)=0
WRITE !
+15 WRITE !,?102,"Verified Adverse Reactions",!,?102,"--------------------------"
+16 SET (ALG,ALGR)=""
FOR
SET ALG=$ORDER(^TMP($JOB,"ALL",1,2,ALG))
if ALG=""
QUIT
FOR
SET ALGR=$ORDER(^TMP($JOB,"ALL",1,2,ALG,ALGR))
if ALGR=""
QUIT
SET III=1
WRITE !,?104,ALGR
+17 WRITE !!,?102,"Non-Verified Adverse Reactions",!,?102,"------------------------------"
+18 SET (ALG,ALGR)=""
FOR
SET ALG=$ORDER(^TMP($JOB,"ALL",2,2,ALG))
if ALG=""
QUIT
FOR
SET ALGR=$ORDER(^TMP($JOB,"ALL",2,2,ALG,ALGR))
if ALGR=""
QUIT
WRITE !,?104,ALGR
+19 KILL ^TMP($JOB,"ALL"),ALGR,PSORY,GMRA,GMRAL,ALG,III,JJJ
WRITE @IOF
QUIT
