source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLS.m@ 660

Last change on this file since 660 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.2 KB
Line 
1PSOLBLS ;BIR/LGH-LABEL FOR SUSPENDED SCRIPTS ;11/17/92 18:18
2 ;;7.0;OUTPATIENT PHARMACY;**5,30**;DEC 1997
3 ;External reference to ^DIC(5 supported by DBIA 10056
4 I '+$G(RXN) Q
5AC S PSODFN=DFN,(SPPL,RXX,STA)=""
6 I $G(PSODTCUT)']"" S X1=DT,X2=-120 D C^%DTC S PSODTCUT=X
7 D ^PSOBUILD S (STA,RXX)=""
8 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
9 G:SPPL="" EXIT
10 D 6^VADPT,PID^VADPT
11 W ?54,$G(VA("PID")),!,?54,$P(^DPT(DFN,0),"^")
12 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)=""
13 I '$P(^PS(59,PSOSITE,1),"^",28) W !,?54,$G(VAPA(1)),!,?54,$G(ADDR(2)),!,?54,$G(ADDR(3)),!
14 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 !
15 W !,?54," The following prescriptions will be"
16 W !,?54,"mailed to you on or after the date indicated."
17 W !!,?54,"Rx# Date"
18 W !,?54,"============================================",!
19 F XX=1:1 Q:$P(SPPL,",",XX)="" S RX=$P(SPPL,",",XX) D
20 .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
21 .W !,?54,$P(^PSRX(RX,0),"^"),?72," ",$G(SPDATE),!,?56,$$ZZ^PSOSUTL(RX) K SPNUM,SPDATE,Y,ZDRUG
22 W @IOF
23EXIT K XX,RX,SPPL,RXX,SPPL,PSOSD,Y,SPNUM,SPDATE Q
24 Q
25MAIL 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)
26 S VAADDR1=$P(PS,"^"),VASTREET=$P(PS,"^",2),STATE=$S($D(^DIC(5,+$P(PS,"^",8),0)):$P(^(0),"^",2),1:"UNKNOWN")
27 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:""))
28 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
29 I '$D(^UTILITY($J,"W",DIWL)) S PSOMAILS=0 G MAILR
30 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
31MAILR I $G(PSOMAILS) S PSKNT=PSKNT+1 W ! D CHECK
32 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
33 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
34 I PSKNT>20 G REXIT
35 I PSKNT<4 W:PSKNT=0 !!!! W:PSKNT=1 !!! W:PSKNT=2 !! W:PSKNT=3 !
36 I PSKNT<4 W "Pharmacy Service (119)",!,$G(VAADDR1),!,$G(VASTREET),!,$P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP) W !!!!!!!!!!!! D PRINT G REXIT
37 I PSKNT=4 W ! W $G(VAADDR1),!,$G(VASTREET),!,$P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP) W !!!!!!!!!!!! D PRINT G REXIT
38 I PSKNT=5 W ! W $G(VASTREET),!,$P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP) W !!!!!!!!!!!! D PRINT G REXIT
39 I PSKNT=6 W ! W $P(PS,"^",7)_", "_$G(STATE)_" "_$G(PSOHZIP) W !!!!!!!!!!!! D PRINT G REXIT
40 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
41 I PSKNT=19 W ! W "copies back to us. Apply enough postage",!,"to your envelope to ensure delivery." G REXIT
42 I PSKNT=20 W ! W "to your envelope to ensure delivery." G REXIT
43 S PSKNT=(20-PSKNT) F PP=1:1:PSKNT W !
44 W ! D PRINT
45REXIT K ^UTILITY($J,"W"),PSKNT,PP,AA,ZZ,DIWL,DIWF,DIWR,PSOMSTOP,PSOMAILS,VAADDR1,VASTREET,STATE,PSZIP,PSOHZIP W @IOF Q
46CHECK 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)
47 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."
48 Q
49PRINT W "Use the label above to mail the computer",!,"copies back to us. Apply enough postage",!,"to your envelope to ensure delivery." Q
50ALL ;PRINT ALLERGIES
51 I $G(PSOBLALL),$P(PPL,",",PI+1)'="" Q
52 X "N X S X=""GMRADPT"" X ^%ZOSF(""TEST"") Q" Q:'$T
53 S GMRA="0^0^111" D ^GMRADPT
54 K ^TMP($J,"ALL")
55 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))=""
56 W ?102,$G(PNM)," ",$G(SSNP),!!
57 W ?102,"Verified Allergies",!,?102,"------------------"
58 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
59 I III W !
60 I 'III W !,?104,$S($G(GMRAL)=0:"NKA",1:"") W:$G(GMRAL)=0 !
61 W !,?102,"Non-Verified Allergies",!,?102,"----------------------"
62 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
63 I III W !
64 I 'III W !,?104,$S($G(GMRAL)=0:"NKA",1:"") W:$G(GMRAL)=0 !
65 W !,?102,"Verified Adverse Reactions",!,?102,"--------------------------"
66 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
67 W !!,?102,"Non-Verified Adverse Reactions",!,?102,"------------------------------"
68 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
69 K ^TMP($J,"ALL"),ALGR,PSORY,GMRA,GMRAL,ALG,III,JJJ W @IOF Q
Note: See TracBrowser for help on using the repository browser.