PSOQMCAL ; SEA/HAM3 PMI - PHARMACY MEDICATION INSTRUCTION ; 30 Nov 2007  7:55 AM
 ;;7.0;OUTPATIENT PHARMACY;**294**;DEC 1997;Build 13
 ;
 ;Reference to CKP^GMTSUP supported by DBIA 4231
 ;Reference to COVER^ORWPS supported by DBIA 4954
 ;Credit to Herb Morriss and Al Hernandez for the original design
 ;Puget Sound Health Care System, Seattle WA
EN N PSOQPEND,DAYSEP,DRUGHDR1,DRUGHDR2,DRUGSEP,INSTSEP1,INSTSEP2,INSTSEP3
 N EMPTYLN,PRETYPE,SUPTYPE,ADDR,AL,ALFLAG,ARLDASH
 N ARLDATE,ARLDFN,ARLDOB,ARLNAME,ARLSITE,ARLSN
 N BLANKLN,BLNKLN,DRUG1,FOOD,GMRAL,IDRUG,ISIG,ITYPE
 N NVA,NONE,PAGE,PGWIDTH,PGLENGTH,PHONE
 N RXIEN,SIGCNT,SIGPOS,XPOS1,XPOS2,XPOS3,XPOS4
 N FN,HP,IA,RPTDATE,TYPE,WP,ST,SUPCNT,SUPDRUG,X,X1,X2,ADDRFL
 N DIWF,DIWL,DIWR,INSTSEP1,INSTSEP2,INSTSEP3,DRUGHDR1,DRUGHDR2,DRUGSEP
 S PGWIDTH=IOM-5,PGLENGTH=IOSL-9
 Q:PGWIDTH<48  ;ensure that the IOM variable is wide enough
 S RPTDATE=$$FMTE^XLFDT($$NOW^XLFDT,"1D")
 S XPOS1=(PGWIDTH-26)\2  ;title
 S XPOS2=PGWIDTH-6       ;page number
 S XPOS3=(PGWIDTH-29)\2  ;site
 S XPOS4=(PGWIDTH-53)\2  ;refill info
 S BLANKLN="",$P(BLNKLN," ",PGWIDTH)=" "
 S EMPTYLN="!,""|"_$E(BLNKLN,1,PGWIDTH-2)_"|"""
 S DAYSEP="|       |       |       |       |"
 S DRUGHDR1="|                 |MORNING| NOON  |EVENING|BEDTIME|       COMMENTS"
 S DRUGHDR1=DRUGHDR1_$E(BLNKLN,$L(DRUGHDR1),PGWIDTH-2)_"|"
 S DRUGHDR2="|                 "_DAYSEP
 S DRUGHDR2=DRUGHDR2_$E(BLNKLN,$L(DRUGHDR2),PGWIDTH-2)_"|"
 S $P(DRUGSEP,"~",PGWIDTH-2)="~"
 S DRUGSEP="|"_DRUGSEP_"|"
 S $P(INSTSEP1,"-",PGWIDTH-2)="-"
 S INSTSEP1="|"_INSTSEP1_"|"
 S INSTSEP2="| UNITS PER DOSE: "_DAYSEP
 S INSTSEP2=INSTSEP2_$E(BLNKLN,$L(INSTSEP2),PGWIDTH-2)_"|"
 S INSTSEP3="|                 "_DAYSEP
 S INSTSEP3=INSTSEP3_$E(BLNKLN,$L(INSTSEP3),PGWIDTH-2)_"|"
 S X1=DT,X2=-45 D C^%DTC S ARLDATE=X
1 ;Patient
 S ARLDFN=""
 F IA=1:1 S ARLDFN=$P(ARLPAT,";",IA) Q:ARLDFN=""  D
 . S PAGE=1
 . D HD,SHOW(ARLDFN)
 Q
SHOW(PTIEN) ;
 N LIST,NVA
 D COVER^ORWPS(.LIST,PTIEN)
 D GETOPORD(.LIST)
 D GETRXDAT(.LIST)
 S SUPTYPE=0,PRETYPE="D"
 S ITYPE="@"
 F  S ITYPE=$O(LIST(ITYPE)) Q:ITYPE]"ZZZ"  Q:ITYPE=""  D
 . I PRETYPE'=ITYPE D
 . . W !,DRUGSEP
 . . W @EMPTYLN
 . . W !,"|","SUPPLY ITEMS:"_$E(BLNKLN,14,PGWIDTH-2)_"|"
 . . S PRETYPE=ITYPE
 . . I (ITYPE="S")&(SUPTYPE=0) D
 . . . S SUPTYPE=1,SUPCNT=0,SUPDRUG=""
 . . . F  S SUPDRUG=$O(LIST(ITYPE,SUPDRUG)) Q:SUPDRUG=""  D
 . . . . S SUPCNT=SUPCNT+1
 . . . I $Y>(PGLENGTH-SUPCNT) W !,DRUGSEP,@IOF D HD3
 . S IDRUG=""
 . F  S IDRUG=$O(LIST(ITYPE,IDRUG)) Q:IDRUG=""  D
 . . I 'SUPTYPE D
 . . S SIGCNT=0,SIGPOS=""
 . . F  S SIGPOS=$O(LIST(ITYPE,IDRUG,SIGPOS)) Q:SIGPOS=""  D
 . . . S SIGCNT=SIGCNT+1
 . . I $Y>(PGLENGTH-SIGCNT) W !,DRUGSEP,@IOF D HD3
 . . W:'SUPTYPE !,DRUGSEP,@EMPTYLN
 . . W !,"|",IDRUG_$E(BLNKLN,$L(IDRUG),PGWIDTH-3)_"|"
 . . Q:SUPTYPE
 . . S ISIG=0
 . . F  S ISIG=$O(LIST(ITYPE,IDRUG,ISIG)) Q:ISIG<1  D
 . . . W !,"|     ",LIST(ITYPE,IDRUG,ISIG),$E(BLNKLN,$L(LIST(ITYPE,IDRUG,ISIG)),PGWIDTH-8),"|"
 . . W !,INSTSEP1,!,INSTSEP2 W:'$G(PSOQHS) !,INSTSEP3
NVA ;NVA MEDS ADDED 5/6/05
 I $D(NVA) D
 . N NVACNT,NVADRUG
 . W !,DRUGSEP
 . W @EMPTYLN
 . W !,"|","NON-VA Medications:"_$E(BLNKLN,20,PGWIDTH-2)_"|"
 . W @EMPTYLN
 . S NVACNT=0
 . S NVADRUG=""
 . F  S NVADRUG=$O(NVA(NVADRUG)) Q:NVADRUG=""  D
 . . S NVACNT=NVACNT+1
 . . I $Y>(PGLENGTH-NVACNT) W !,DRUGSEP,@IOF D HD3
 . . W !,"|",NVADRUG_$E(BLNKLN,$L(NVADRUG),PGWIDTH-3)_"|"
 K NVACNT,NVADRUG
 W !,INSTSEP1
 D
 . Q:'$G(PSOQPEND)
 . W !!,"Any medication items listed as ""pending"" are those that have just been" D PGE Q:$D(GMTSQIT)
 . W !,"written by your provider(s).  These medication orders will be reviewed" D PGE Q:$D(GMTSQIT)
 . W !,"by your pharmacist, prior to the prescription(s) being dispensed.  When" D PGE Q:$D(GMTSQIT)
 . W !,"you receive your new prescription(s), by mail or from the pharmacy window," D PGE Q:$D(GMTSQIT)
 . W !,"be sure to follow the instructions on the prescription label.  If you" D PGE Q:$D(GMTSQIT)
 . W !,"have any question about your medication, please call your provider or " D PGE Q:$D(GMTSQIT)
 . W !,"your pharmacist." D PGE Q:$D(GMTSQIT)
 Q
PGE D:$G(PSOQHS) CKP^GMTSUP
 Q
GETOPORD(ORDLIST) ;
 N LISTIEN,KILLORD
 S LISTIEN=0
 F  S LISTIEN=$O(ORDLIST(LISTIEN)) Q:LISTIEN<1  D
 . S KILLORD=$$IPORD(ORDLIST(LISTIEN))
 . I 'KILLORD S KILLORD=$$CKSTATUS(ORDLIST(LISTIEN)) D
 . K:KILLORD ORDLIST(LISTIEN)
 Q
IPORD(LISTNODE) ;
 N RETURN,PKG
 S RETURN=0
 S PKG=$P($P(LISTNODE,"^",1),";",2)
 I "UI"[PKG S RETURN=1
 I $P(LISTNODE,"^",1)["N;" D
 . S:$P(LISTNODE,"^",4)="ACTIVE" NVA($P(LISTNODE,"^",2),+LISTNODE)=LISTNODE
 . S RETURN=1
 Q RETURN
CKSTATUS(LISTNODE) ;
 N RETURN,RXIEN
 S RETURN=0 ; ASSUME ACTIVE AND NOT PASS MED
 S:$P(LISTNODE,"^",4)["DISCONTINUED" RETURN=1
 S:$P(LISTNODE,"^",4)["EXPIRED" RETURN=1
 Q RETURN
GETRXDAT(RXS) ;
 N RXSIEN,DRUGNAME,FSIG,RXTYPE
 S RXSIEN=0
 F  S RXSIEN=$O(RXS(RXSIEN)) Q:RXSIEN<1  D
 . I $P(RXS(RXSIEN),";")["P" D GETPEND(RXSIEN) S PSOQPEND=1 Q  ;-> 
 . S RXIEN=+RXS(RXSIEN)
 . S DRUGNAME=$$ZZ^PSOSUTL(RXIEN)
 . D FSIG^PSOUTLA("R",RXIEN,PGWIDTH-8)
 . S RXTYPE=$$GETTYPE(RXIEN)
 . M RXS(RXTYPE,DRUGNAME)=FSIG
 . N PSOQSUB
 . S PSOQSUB=$O(RXS(RXTYPE,DRUGNAME,":"),-1)+1
 . S RXS(RXTYPE,DRUGNAME,PSOQSUB)=$$REFILLS^PSOQ0076(RXIEN)_" refill(s) remaining prior to "_$$FMTE^XLFDT($$EXPDATE^PSOQ0076(RXIEN))
 Q
GETPEND(RXSIEN) ;RMS/HINES 8-16-07 ADD PENDING RX'S
 N PSOQPDN,PSOQDIND,PSOQOIND,PSOQ100,PSOQSIND,PSOQSCT,PSOQRAW,SUB
 S PSOQ100=$P(RXS(RXSIEN),U,3) Q:'+PSOQ100
 S PSOQOIND=$O(^OR(100,PSOQ100,4.5,"ID","ORDERABLE",0)) Q:'+PSOQOIND
 S PSOQPDN=$P($G(^ORD(101.43,+$G(^OR(100,PSOQ100,4.5,PSOQOIND,1)),0)),U)
 S PSOQDIND=$O(^OR(100,PSOQ100,4.5,"ID","DRUG",0)) D
 . Q:'+PSOQDIND
 . S PSOQPDN=$P($G(^PSDRUG(+$G(^OR(100,PSOQ100,4.5,PSOQDIND,1)),0)),U)
 S PSOQSIND=$O(^OR(100,PSOQ100,8,":"),-1) Q:'+PSOQSIND
 F PSOQSCT=2:1:$O(^OR(100,PSOQ100,8,PSOQSIND,.1,":"),-1) D
 . S PSOQRAW=$G(^OR(100,PSOQ100,8,PSOQSIND,.1,PSOQSCT,0))
 . N WORDS,COUNT,LINE,NEXTWORD
 . S WORDS=$L(PSOQRAW," "),SUB=$G(SUB,0)+1
 . F COUNT=1:1:WORDS D
 .. S NEXTWORD=$P(PSOQRAW," ",COUNT)
 .. Q:NEXTWORD=""
 .. S LINE=$G(LINE)_NEXTWORD_" "
 .. I $L($G(LINE))>65&(COUNT'=WORDS) K LINE S SUB=SUB+1
 .. S RXS("D","**PENDING**"_PSOQPDN,SUB)=$G(RXS("D","**PENDING**"_PSOQPDN,SUB))_NEXTWORD_" "
 Q
GETTYPE(IEN52) ;
 N RETURN,CLASS
 S RETURN="D"
 S CLASS=$$GETCLASS(IEN52)
 S:$E(CLASS,1,1)="X" RETURN="S"
 S:$E(CLASS,1,2)="DX" RETURN="S"
 Q RETURN
GETCLASS(IENRX) ;
 N RETURN,NODE0RX,IENDRUG,NODE0DRG,NODEND50,IENCLASS,NODE0CLS,VACLASS
 S RETURN=""
 S NODE0RX=$G(^PSRX(IENRX,0))
 S IENDRUG=$P(NODE0RX,"^",6)
 Q:+IENDRUG=0 RETURN
 S NODE0DRG=$G(^PSDRUG(IENDRUG,0))
 S NODEND50=$G(^PSDRUG(IENDRUG,"ND"))
 S IENCLASS=$P(NODEND50,"^",6)
 Q:+IENCLASS=0 RETURN
 S NODE0CLS=$G(^PS(50.605,IENCLASS,0))
 S VACLASS=$P(NODE0CLS,"^",1)
 S RETURN=VACLASS
 Q RETURN
HD ;
 S FN=ARLDFN
 S ARLNAME=$E($P(^DPT(ARLDFN,0),"^",1),1,28)
 S ARLSN=$P(^(0),"^",9),ARLDOB=$P(^(0),"^",3)
 S PHONE=$S($D(^DPT(ARLDFN,.13)):^(.13),1:"")
 S HP=$P(PHONE,"^",1),WP=$P(PHONE,"^",2)
 S ADDR=$S($D(^DPT(ARLDFN,.11)):^(.11),1:"")
 I $D(^DPT(ARLDFN,.121)),$P(^(.121),"^",9)="Y" D
 . S X=$S($P(^(.121),"^",8):$P(^(.121),"^",8),1:9999999)
 . I DT'<$P(^(.121),"^",7),DT'>X D
 . . S ADDR=^(.121)
 . . S ADDRFL="(temporary)"
 . . S HP=$P(ADDR,"^",10)
 S ST=$S($D(^DIC(5,+$P(ADDR,"^",5),0)):$P(^(0),"^",2),1:"UNKNOWN")
 S ADDR(4)=$P(ADDR,"^",4)_", "_ST_"  "_$P(ADDR,"^",6)
 S ADDR(3)=$P(ADDR,"^",3),ADDR(2)=$P(ADDR,"^",2),ADDR(1)=$P(ADDR,"^",1)
 I ADDR(2)']"" D
 . S ADDR(2)=ADDR(3)
 . S ADDR(3)=""
HD1 ; Header for 1st page
 S ARLSITE=^PS(59,PSOSITE,0)
 D PGE Q:$D(GMTSQIT)
 W !,"Date: ",RPTDATE,?XPOS1,"PATIENT MEDICATION INFORMATION"
 I $D(PAGE) D
 . W ?XPOS2,"Page: ",PAGE
 . S PAGE=PAGE+1
 W !,?XPOS4,"PRINTED BY THE VA MEDICAL CENTER AT: "_$P($G(^DIC(4,+$G(^PS(59,PSOSITE,"INI")),0)),U,1)
 W !,?XPOS4,"FOR PRESCRIPTION REFILLS CALL ("_$P(ARLSITE,U,3)_") "_$P(ARLSITE,U,4)
HD2 W !!,"Name: ",$E(ARLNAME,1,40)," - ",$E(ARLSN,6,9)
 W ?30," PHARMACY - ",$P(ARLSITE,"^",7)," DIVISION (",$P(ARLSITE,"^",3),"-",$P(ARLSITE,"^",4),")",!
 W !,INSTSEP1,!,DRUGHDR1 ;!,DRUGHDR2
 Q
HD3 ;Header for subsequent pages
 W !,"Date: ",RPTDATE,?XPOS1,"PATIENT MEDICATION INFORMATION"
 I $D(PAGE) W ?XPOS2,"Page: ",PAGE S PAGE=PAGE+1
 W !,?XPOS4,"PRINTED BY THE VA MEDICAL CENTER AT: "_$P($G(^DIC(4,+$G(^PS(59,PSOSITE,"INI")),0)),U,1)
 W !,?XPOS4,"FOR PRESCRIPTION REFILLS CALL ("_$P(ARLSITE,U,3)_") "_$P(ARLSITE,U,4),!
 W !?1,"Name: ",$E(ARLNAME,1,40)," - ",$E(ARLSN,6,9)
 W ?30," PHARMACY - ",$P(ARLSITE,"^",7)," DIVISION (",$P(ARLSITE,"^",3),"-",$P(ARLSITE,"^",4),")",!
 W !,INSTSEP1
 W:$G(SUPCNT)&'$G(NVACNT) !,"|","SUPPLY ITEMS:"_$E(BLNKLN,14,PGWIDTH-2)_"|",@EMPTYLN
 W:$G(NVACNT) @EMPTYLN,!,"|","NON-VA Medications:"_$E(BLNKLN,20,PGWIDTH-2)_"|",@EMPTYLN
 W:'$G(NVACNT)&'$G(SUPCNT) !,DRUGHDR1
 Q
RE ;Allergies
 S ARLDASH="",$P(ARLDASH,"=",$E(BLNKLN,1,PGWIDTH-10))=ARLDASH W !,ARLDASH,!!
 S NONE="NO INFORMATION (COMPLETE SECTION BELOW)",ALFLAG=0 D ALL
 W "REACTIONS/ALLERGIES currently on file : ",$S($D(GMRAL):"",1:NONE) Q:'$D(GMRAL)
 S X=DRUG1_FOOD,DIWL=5,DIWR=PGWIDTH-5,DIWF="W" D ^DIWP,^DIWW
 Q
ALL ;Gets allergy info
 K GMRA,GMRAL
 N IFN,DATA,VER,ARLEND
 S ARLEND=0,DFN=ARLDFN,GMRA="0^0^011" D ^GMRADPT S (DRUG1,FOOD)=""
 I $D(GMRAL),GMRAL=0 S DRUG1="NO KNOWN ALLERGIES"
 I $D(GMRAL),GMRAL=1 S IFN="" F  S IFN=$O(GMRAL(IFN)) Q:IFN=""!(ARLEND)  S DATA=GMRAL(IFN),AL=$P(DATA,U,2),TYPE=$P(DATA,U,3),VER=$S($P(DATA,U,4)=1:"V",1:"NV") D
 .I $L(DRUG1)>300 S DRUG1="TOO MANY TO LIST",ARLEND=1
 .S:TYPE="D" DRUG1=AL_" ("_VER_"),"_DRUG1
 .S:TYPE="F" FOOD="Food Allergies on File"
 Q
