- 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
- 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
