Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSORLLL5

PSORLLL5.m

Go to the documentation of this file.
PSORLLL5 ;AITC/BWF - LASER LABEL CONTINUED ;11/14/05 10:09am
 ;;7.0;OUTPATIENT PHARMACY;**454**;DEC 1997;Build 349
 ; BWF - OneVa Pharmacy modified copy of PSOLLL5
 ;
START ;
 N TEXT,BLNKLIN
 S $P(BLNKLIN,"_",90)="_"
 D MAIL
 I $G(PSOIO("ACI"))]"" X PSOIO("ACI")
 S TEXT="HAS YOUR ADDRESS CHANGED?" D STRT^PSOLLU1("SEC2",TEXT,.L)
 S OPSOX=PSOX,PSOX=4.2-L($E(PSOHFONT,2,99))*300/2+OPSOX
 S OFONT=PSOFONT,PSOFONT=$G(PSOHFONT,OFONT) D PRINT(TEXT,1) S PSOX=OPSOX,PSOY=PSOY+10,PSOFONT=OFONT
 S TEXT="Write address changes in the blanks, sign the form, and return to" D PRINT(TEXT,0)
 S TEXT="your pharmacy." D PRINT(TEXT,0)
 S X=$S($D(^DPT(DFN,0))#2:^(0),1:""),PNM=$P(X,"^")
 D PID^VADPT6,ADD^VADPT S SSNP=""
 S PSOY=PSOY+PSOYI,TEXT=PNM_"  "_SSNP D PRINT(TEXT,0)
 I $G(VAPA(1))="" G ALLERGY
 F I=1:1:3 I $G(VAPA(I))]"" S TEXT=$G(VAPA(I))_$E(BLNKLIN,1,80-$L(VAPA(I))) D PRINT(TEXT,0)
 S A=+$G(VAPA(5)) I A S A=$S($D(^DIC(5,A,0)):$P(^(0),"^",2),1:"UNKNOWN")
 S B=$G(VAPA(4))_", "_A_"  "_$S($G(VAPA(11)):$P(VAPA(11),"^",2),1:$G(VAPA(6)))
 S TEXT=B_$E(BLNKLIN,1,80-$L(B)) D PRINT(TEXT,0)
 S B=VAPA(8)
 S TEXT=B_$E(BLNKLIN,1,80-$L(B)) D PRINT(TEXT,0)
 S:$G(VAPA(3))="" PSOY=PSOY+PSOYI
 S TEXT="[   ] Permanent                     [   ] Temporary until ____/____/____" D PRINT(TEXT,0)
 S PSOY=$G(PSOFY),TEXT="Signature "_$E(BLNKLIN,1,45) D PRINT(TEXT,0)
 ;
ALLERGY ;ALLERGIES & REACTIONS
 K ^TMP($J,"PSOALWA")
 S GMRA="0^0^111" D ^GMRADPT
 I $G(GMRAL) S PSORY=0 F  S PSORY=$O(GMRAL(PSORY)) Q:'PSORY  S ^TMP($J,"PSOALWA",$S($P(GMRAL(PSORY),"^",4):1,1:2),$S('$P(GMRAL(PSORY),"^",5):1,1:2),$P(GMRAL(PSORY),"^",7),$P(GMRAL(PSORY),"^",2))=""
 S ^TMP($J,"PSOAPT",1)=$G(PNM)_"  "_$G(SSNP),^(2)="Verified Allergies"
 S ALCNT=0,EEE=0,(PSOLG,PSOLGA)="" F  S PSOLG=$O(^TMP($J,"PSOALWA",1,1,PSOLG)) Q:PSOLG=""  F  S PSOLGA=$O(^TMP($J,"PSOALWA",1,1,PSOLG,PSOLGA)) Q:PSOLGA=""  S EEE=1,ALCNT=ALCNT+1,^TMP($J,"PSOAPT",2,ALCNT)=PSOLGA
 I 'EEE,$G(GMRAL)=0 S ALCNT=ALCNT+1,^TMP($J,"PSOAPT",2,ALCNT)="NKA"
 S ALCNT=0,^TMP($J,"PSOAPT",3)="Non-Verified Allergies"
 S EEE=0,(PSOLG,PSOLGA)="" F  S PSOLG=$O(^TMP($J,"PSOALWA",2,1,PSOLG)) Q:PSOLG=""  F  S PSOLGA=$O(^TMP($J,"PSOALWA",2,1,PSOLG,PSOLGA)) Q:PSOLGA=""  S EEE=EEE+1,ALCNT=ALCNT+1,^TMP($J,"PSOAPT",3,ALCNT)=PSOLGA
 I 'EEE,$G(GMRAL)=0 S ALCNT=ALCNT+1,^TMP($J,"PSOAPT",3,ALCNT)="NKA"
 S ALCNT=0,^TMP($J,"PSOAPT",4)="Verified Adverse Reactions"
 S (PSOLG,PSOLGA)="" F  S PSOLG=$O(^TMP($J,"PSOALWA",1,2,PSOLG)) Q:PSOLG=""  F  S PSOLGA=$O(^TMP($J,"PSOALWA",1,2,PSOLG,PSOLGA)) Q:PSOLGA=""  S ALCNT=ALCNT+1,^TMP($J,"PSOAPT",4,ALCNT)=PSOLGA
 S ALCNT=0,^TMP($J,"PSOAPT",5)="Non-Verified Adverse Reactions"
 S (PSOLG,PSOLGA)="" F  S PSOLG=$O(^TMP($J,"PSOALWA",2,2,PSOLG)) Q:PSOLG=""  F  S PSOLGA=$O(^TMP($J,"PSOALWA",2,2,PSOLG,PSOLGA)) Q:PSOLGA=""  S ALCNT=ALCNT+1,^TMP($J,"PSOAPT",5,ALCNT)=PSOLGA
 I $G(PSOIO("ALI"))]"" X PSOIO("ALI")
 S XFONT=$E($G(PSOFONT),2,99)
 S OFONT=PSOFONT,PSOFONT=$G(PSOHFONT,PSOFONT) S TEXT=^TMP($J,"PSOAPT",1) D PRINT(TEXT,1) S PSOFONT=OFONT
 S TEXT="" D PRINT(TEXT,0)
 F CCC=3,4,5 I '$O(^TMP($J,"PSOAPT",CCC,0)) K ^TMP($J,"PSOAPT",CCC)
 D ASSESS
 I CCC="NKA" S ^TMP($J,"PSOAPT",2,1)="No Known Allergies" K ^TMP($J,"PSOAPT",3)
 S CCC=1,OUT=0
 F  S CCC=$O(^TMP($J,"PSOAPT",CCC)) Q:CCC=""  D  Q:OUT
 .S TEXT=$G(^TMP($J,"PSOAPT",CCC))
 .I $G(PSOIO(PSOFONT))]"" X PSOIO(PSOFONT)
 .S PSOY=PSOY+PSOYI D PRINT(TEXT,0,1)
 .I TEXT="No Assessment Made" Q
 .I PSOY>PSOYM S OUT=1 Q
 .S (TEXT,PTEXT,CCC2)="",LENGTH=0
 .F  S CCC2=$O(^TMP($J,"PSOAPT",CCC,CCC2)) Q:CCC2=""  S TEXT=^(CCC2) D  Q:OUT
 ..D STRT^PSOLLU1("SEC2",TEXT,.L)
 ..I LENGTH+L(XFONT)<3.7 S PTEXT=PTEXT_TEXT_",",LENGTH=LENGTH+L(XFONT) Q
 ..I PTEXT="" D  Q
 ... F JJ=$L(TEXT):-1 S PTEXT=$E(TEXT,1,JJ) D STRT^PSOLLU1("SEC2",PTEXT,.L) I L(XFONT)<3.7 D PRINT(PTEXT,0) S PTEXT=$E(TEXT,JJ+1,512)_"," Q
 ... D STRT^PSOLLU1("SEC2",PTEXT,.L) S LENGTH=L(XFONT)
 ..S LENGTH=0,CCC2=CCC2-1
 ..I PSOY>PSOYM S OUT=1 Q
 ..D PRINT(PTEXT,0) S PTEXT=""
 .I 'OUT,PTEXT]"" D PRINT($P(PTEXT,",",1,$L(PTEXT,",")-1),0)
 I OUT S T="Additional Allergies or Adverse Reactions Exist." D PRINT(T,0) S T="Talk to your Physician or Pharmacist." D PRINT(T,0)
 K ^TMP($J,"PSOALWA"),^TMP($J,"PSOAPT"),PSONKA,PSONULL,WWW,GMRA,GMRAL,JJJ,WCNT,RRR,ALG,ALCNT,EEE,FFF,PSOLG,PSOLGA,PSORY,CCC,CCC2,FNTFLG,TEXT,TEXT2
 Q
PRINT(T,B,UL) ;
 S BOLD=$G(B),UL=$G(UL)
 I 'BOLD,$G(PSOIO(PSOFONT))]"" X PSOIO(PSOFONT)
 I BOLD,$G(PSOIO(PSOFONT_"B"))]"" X PSOIO(PSOFONT_"B")
 I $G(PSOIO("ST"))]"" X PSOIO("ST")
 I UL,$G(PSOIO("FWU"))]"" X PSOIO("FWU")
 W T,!
 I UL,$G(PSOIO("FDU"))]"" X PSOIO("FDU")
 I $G(PSOIO("ET"))]"" X PSOIO("ET")
 I BOLD,$G(PSOIO(PSOFONT))]"" X PSOIO(PSOFONT) ;TURN OFF BOLDING
 Q
ASSESS ;
 N FLG3,FLG4,FLG5
 S CCC=$G(^TMP($J,"PSOAPT",2,1))
 S FLG3=$G(^TMP($J,"PSOAPT",3,1))
 S FLG4=$G(^TMP($J,"PSOAPT",4,1))
 S FLG5=$G(^TMP($J,"PSOAPT",5,1))
 I CCC="",FLG3="",FLG4="",FLG5="" S ^TMP($J,"PSOAPT",2,1)="No Assessment Made" K ^TMP($J,"PSOAPT",3)
 Q
MAIL ;PRINT MAILING ADHESIVE LABEL
 ;S 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(HINFO,"^"),VASTREET=$P($P(HINFO,"^",2),"~"),STATE=$S($P($P(HINFO,"^",2),"~",4)]"":$P($P(HINFO,"^",2),"~",4),1:"UNKNOWN")
 S PSZIP=$P($P($P(HINFO,"^",2),"~",5),"&"),PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
 I $G(PSOIO("MLI"))]"" X PSOIO("MLI")
 I $G(PSOIO("PSOFONT"))]"" X PSOIO("PSOFONT")
 S TEXT="Attn: (119)" D PRINT(TEXT)
 S TEXT=VAADDR1 D PRINT(TEXT)
 S TEXT=$G(VASTREET) D PRINT(TEXT)
 S TEXT=$P($P(HINFO,"^",2),"~",3)_", "_$G(STATE)_"  "_$G(PSOHZIP) D PRINT(TEXT)
 Q