Routine: PSOQMCAL

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)

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

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

PGE D:$G(PSOQHS) CKP^GMTSUP

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)

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

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

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

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

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

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"

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOQMCAL   9801     printed  Feb 18, 2025@23:59:46                                                                                                                                                                                                    Page 2

PSOQMCAL  ; SEA/HAM3 PMI - PHARMACY MEDICATION INSTRUCTION ; 30 Nov 2007  7:55 AM

 +1       ;;7.0;OUTPATIENT PHARMACY;**294**;DEC 1997;Build 13

 +2       ;

 +3       ;Reference to CKP^GMTSUP supported by DBIA 4231

 +4       ;Reference to COVER^ORWPS supported by DBIA 4954

 +5       ;Credit to Herb Morriss and Al Hernandez for the original design

 +6       ;Puget Sound Health Care System, Seattle WA

EN         NEW PSOQPEND,DAYSEP,DRUGHDR1,DRUGHDR2,DRUGSEP,INSTSEP1,INSTSEP2,INSTSEP3

 +1        NEW EMPTYLN,PRETYPE,SUPTYPE,ADDR,AL,ALFLAG,ARLDASH

 +2        NEW ARLDATE,ARLDFN,ARLDOB,ARLNAME,ARLSITE,ARLSN

 +3        NEW BLANKLN,BLNKLN,DRUG1,FOOD,GMRAL,IDRUG,ISIG,ITYPE

 +4        NEW NVA,NONE,PAGE,PGWIDTH,PGLENGTH,PHONE

 +5        NEW RXIEN,SIGCNT,SIGPOS,XPOS1,XPOS2,XPOS3,XPOS4

 +6        NEW FN,HP,IA,RPTDATE,TYPE,WP,ST,SUPCNT,SUPDRUG,X,X1,X2,ADDRFL

 +7        NEW DIWF,DIWL,DIWR,INSTSEP1,INSTSEP2,INSTSEP3,DRUGHDR1,DRUGHDR2,DRUGSEP

 +8        SET PGWIDTH=IOM-5

           SET PGLENGTH=IOSL-9

 +9       ;ensure that the IOM variable is wide enough

           if PGWIDTH<48

               QUIT

 +10       SET RPTDATE=$$FMTE^XLFDT($$NOW^XLFDT,"1D")

 +11      ;title

           SET XPOS1=(PGWIDTH-26)\2

 +12      ;page number

           SET XPOS2=PGWIDTH-6

 +13      ;site

           SET XPOS3=(PGWIDTH-29)\2

 +14      ;refill info

           SET XPOS4=(PGWIDTH-53)\2

 +15       SET BLANKLN=""

           SET $PIECE(BLNKLN," ",PGWIDTH)=" "

 +16       SET EMPTYLN="!,""|"_$EXTRACT(BLNKLN,1,PGWIDTH-2)_"|"""

 +17       SET DAYSEP="|       |       |       |       |"

 +18       SET DRUGHDR1="|                 |MORNING| NOON  |EVENING|BEDTIME|       COMMENTS"

 +19       SET DRUGHDR1=DRUGHDR1_$EXTRACT(BLNKLN,$LENGTH(DRUGHDR1),PGWIDTH-2)_"|"

 +20       SET DRUGHDR2="|                 "_DAYSEP

 +21       SET DRUGHDR2=DRUGHDR2_$EXTRACT(BLNKLN,$LENGTH(DRUGHDR2),PGWIDTH-2)_"|"

 +22       SET $PIECE(DRUGSEP,"~",PGWIDTH-2)="~"

 +23       SET DRUGSEP="|"_DRUGSEP_"|"

 +24       SET $PIECE(INSTSEP1,"-",PGWIDTH-2)="-"

 +25       SET INSTSEP1="|"_INSTSEP1_"|"

 +26       SET INSTSEP2="| UNITS PER DOSE: "_DAYSEP

 +27       SET INSTSEP2=INSTSEP2_$EXTRACT(BLNKLN,$LENGTH(INSTSEP2),PGWIDTH-2)_"|"

 +28       SET INSTSEP3="|                 "_DAYSEP

 +29       SET INSTSEP3=INSTSEP3_$EXTRACT(BLNKLN,$LENGTH(INSTSEP3),PGWIDTH-2)_"|"

 +30       SET X1=DT

           SET X2=-45

           DO C^%DTC

           SET ARLDATE=X

1         ;Patient

 +1        SET ARLDFN=""

 +2        FOR IA=1:1

               SET ARLDFN=$PIECE(ARLPAT,";",IA)

               if ARLDFN=""

                   QUIT

               Begin DoDot:1

 +3                SET PAGE=1

 +4                DO HD

                   DO SHOW(ARLDFN)

               End DoDot:1

 +5        QUIT

SHOW(PTIEN) ;

 +1        NEW LIST,NVA

 +2        DO COVER^ORWPS(.LIST,PTIEN)

 +3        DO GETOPORD(.LIST)

 +4        DO GETRXDAT(.LIST)

 +5        SET SUPTYPE=0

           SET PRETYPE="D"

 +6        SET ITYPE="@"

 +7        FOR

               SET ITYPE=$ORDER(LIST(ITYPE))

               if ITYPE]"ZZZ"

                   QUIT

               if ITYPE=""

                   QUIT

               Begin DoDot:1

 +8                IF PRETYPE'=ITYPE

                       Begin DoDot:2

 +9                        WRITE !,DRUGSEP

 +10                       WRITE @EMPTYLN

 +11                       WRITE !,"|","SUPPLY ITEMS:"_$EXTRACT(BLNKLN,14,PGWIDTH-2)_"|"

 +12                       SET PRETYPE=ITYPE

 +13                       IF (ITYPE="S")&(SUPTYPE=0)

                               Begin DoDot:3

 +14                               SET SUPTYPE=1

                                   SET SUPCNT=0

                                   SET SUPDRUG=""

 +15                               FOR

                                       SET SUPDRUG=$ORDER(LIST(ITYPE,SUPDRUG))

                                       if SUPDRUG=""

                                           QUIT

                                       Begin DoDot:4

 +16                                       SET SUPCNT=SUPCNT+1

                                       End DoDot:4

 +17                               IF $Y>(PGLENGTH-SUPCNT)

                                       WRITE !,DRUGSEP,@IOF

                                       DO HD3

                               End DoDot:3

                       End DoDot:2

 +18               SET IDRUG=""

 +19               FOR

                       SET IDRUG=$ORDER(LIST(ITYPE,IDRUG))

                       if IDRUG=""

                           QUIT

                       Begin DoDot:2

 +20                       IF 'SUPTYPE

                               Begin DoDot:3

                               End DoDot:3

 +21                       SET SIGCNT=0

                           SET SIGPOS=""

 +22                       FOR

                               SET SIGPOS=$ORDER(LIST(ITYPE,IDRUG,SIGPOS))

                               if SIGPOS=""

                                   QUIT

                               Begin DoDot:3

 +23                               SET SIGCNT=SIGCNT+1

                               End DoDot:3

 +24                       IF $Y>(PGLENGTH-SIGCNT)

                               WRITE !,DRUGSEP,@IOF

                               DO HD3

 +25                       if 'SUPTYPE

                               WRITE !,DRUGSEP,@EMPTYLN

 +26                       WRITE !,"|",IDRUG_$EXTRACT(BLNKLN,$LENGTH(IDRUG),PGWIDTH-3)_"|"

 +27                       if SUPTYPE

                               QUIT

 +28                       SET ISIG=0

 +29                       FOR

                               SET ISIG=$ORDER(LIST(ITYPE,IDRUG,ISIG))

                               if ISIG<1

                                   QUIT

                               Begin DoDot:3

 +30                               WRITE !,"|     ",LIST(ITYPE,IDRUG,ISIG),$EXTRACT(BLNKLN,$LENGTH(LIST(ITYPE,IDRUG,ISIG)),PGWIDTH-8),"|"

                               End DoDot:3

 +31                       WRITE !,INSTSEP1,!,INSTSEP2

                           if '$GET(PSOQHS)

                               WRITE !,INSTSEP3

                       End DoDot:2

               End DoDot:1

NVA       ;NVA MEDS ADDED 5/6/05

 +1        IF $DATA(NVA)

               Begin DoDot:1

 +2                NEW NVACNT,NVADRUG

 +3                WRITE !,DRUGSEP

 +4                WRITE @EMPTYLN

 +5                WRITE !,"|","NON-VA Medications:"_$EXTRACT(BLNKLN,20,PGWIDTH-2)_"|"

 +6                WRITE @EMPTYLN

 +7                SET NVACNT=0

 +8                SET NVADRUG=""

 +9                FOR

                       SET NVADRUG=$ORDER(NVA(NVADRUG))

                       if NVADRUG=""

                           QUIT

                       Begin DoDot:2

 +10                       SET NVACNT=NVACNT+1

 +11                       IF $Y>(PGLENGTH-NVACNT)

                               WRITE !,DRUGSEP,@IOF

                               DO HD3

 +12                       WRITE !,"|",NVADRUG_$EXTRACT(BLNKLN,$LENGTH(NVADRUG),PGWIDTH-3)_"|"

                       End DoDot:2

               End DoDot:1

 +13       KILL NVACNT,NVADRUG

 +14       WRITE !,INSTSEP1

 +15       Begin DoDot:1

 +16           if '$GET(PSOQPEND)

                   QUIT

 +17           WRITE !!,"Any medication items listed as ""pending"" are those that have just been"

               DO PGE

               if $DATA(GMTSQIT)

                   QUIT

 +18           WRITE !,"written by your provider(s).  These medication orders will be reviewed"

               DO PGE

               if $DATA(GMTSQIT)

                   QUIT

 +19           WRITE !,"by your pharmacist, prior to the prescription(s) being dispensed.  When"

               DO PGE

               if $DATA(GMTSQIT)

                   QUIT

 +20           WRITE !,"you receive your new prescription(s), by mail or from the pharmacy window,"

               DO PGE

               if $DATA(GMTSQIT)

                   QUIT

 +21           WRITE !,"be sure to follow the instructions on the prescription label.  If you"

               DO PGE

               if $DATA(GMTSQIT)

                   QUIT

 +22           WRITE !,"have any question about your medication, please call your provider or "

               DO PGE

               if $DATA(GMTSQIT)

                   QUIT

 +23           WRITE !,"your pharmacist."

               DO PGE

               if $DATA(GMTSQIT)

                   QUIT

           End DoDot:1

 +24       QUIT

PGE        if $GET(PSOQHS)

               DO CKP^GMTSUP

 +1        QUIT

GETOPORD(ORDLIST) ;

 +1        NEW LISTIEN,KILLORD

 +2        SET LISTIEN=0

 +3        FOR

               SET LISTIEN=$ORDER(ORDLIST(LISTIEN))

               if LISTIEN<1

                   QUIT

               Begin DoDot:1

 +4                SET KILLORD=$$IPORD(ORDLIST(LISTIEN))

 +5                IF 'KILLORD

                       SET KILLORD=$$CKSTATUS(ORDLIST(LISTIEN))

                       Begin DoDot:2

                       End DoDot:2

 +6                if KILLORD

                       KILL ORDLIST(LISTIEN)

               End DoDot:1

 +7        QUIT

IPORD(LISTNODE) ;

 +1        NEW RETURN,PKG

 +2        SET RETURN=0

 +3        SET PKG=$PIECE($PIECE(LISTNODE,"^",1),";",2)

 +4        IF "UI"[PKG

               SET RETURN=1

 +5        IF $PIECE(LISTNODE,"^",1)["N;"

               Begin DoDot:1

 +6                if $PIECE(LISTNODE,"^",4)="ACTIVE"

                       SET NVA($PIECE(LISTNODE,"^",2),+LISTNODE)=LISTNODE

 +7                SET RETURN=1

               End DoDot:1

 +8        QUIT RETURN

CKSTATUS(LISTNODE) ;

 +1        NEW RETURN,RXIEN

 +2       ; ASSUME ACTIVE AND NOT PASS MED

           SET RETURN=0

 +3        if $PIECE(LISTNODE,"^",4)["DISCONTINUED"

               SET RETURN=1

 +4        if $PIECE(LISTNODE,"^",4)["EXPIRED"

               SET RETURN=1

 +5        QUIT RETURN

GETRXDAT(RXS) ;

 +1        NEW RXSIEN,DRUGNAME,FSIG,RXTYPE

 +2        SET RXSIEN=0

 +3        FOR

               SET RXSIEN=$ORDER(RXS(RXSIEN))

               if RXSIEN<1

                   QUIT

               Begin DoDot:1

 +4       ;->

                   IF $PIECE(RXS(RXSIEN),";")["P"

                       DO GETPEND(RXSIEN)

                       SET PSOQPEND=1

                       QUIT

 +5                SET RXIEN=+RXS(RXSIEN)

 +6                SET DRUGNAME=$$ZZ^PSOSUTL(RXIEN)

 +7                DO FSIG^PSOUTLA("R",RXIEN,PGWIDTH-8)

 +8                SET RXTYPE=$$GETTYPE(RXIEN)

 +9                MERGE RXS(RXTYPE,DRUGNAME)=FSIG

 +10               NEW PSOQSUB

 +11               SET PSOQSUB=$ORDER(RXS(RXTYPE,DRUGNAME,":"),-1)+1

 +12               SET RXS(RXTYPE,DRUGNAME,PSOQSUB)=$$REFILLS^PSOQ0076(RXIEN)_" refill(s) remaining prior to "_$$FMTE^XLFDT($$EXPDATE^PSOQ0076(RXIEN))

               End DoDot:1

 +13       QUIT

GETPEND(RXSIEN) ;RMS/HINES 8-16-07 ADD PENDING RX'S

 +1        NEW PSOQPDN,PSOQDIND,PSOQOIND,PSOQ100,PSOQSIND,PSOQSCT,PSOQRAW,SUB

 +2        SET PSOQ100=$PIECE(RXS(RXSIEN),U,3)

           if '+PSOQ100

               QUIT

 +3        SET PSOQOIND=$ORDER(^OR(100,PSOQ100,4.5,"ID","ORDERABLE",0))

           if '+PSOQOIND

               QUIT

 +4        SET PSOQPDN=$PIECE($GET(^ORD(101.43,+$GET(^OR(100,PSOQ100,4.5,PSOQOIND,1)),0)),U)

 +5        SET PSOQDIND=$ORDER(^OR(100,PSOQ100,4.5,"ID","DRUG",0))

           Begin DoDot:1

 +6            if '+PSOQDIND

                   QUIT

 +7            SET PSOQPDN=$PIECE($GET(^PSDRUG(+$GET(^OR(100,PSOQ100,4.5,PSOQDIND,1)),0)),U)

           End DoDot:1

 +8        SET PSOQSIND=$ORDER(^OR(100,PSOQ100,8,":"),-1)

           if '+PSOQSIND

               QUIT

 +9        FOR PSOQSCT=2:1:$ORDER(^OR(100,PSOQ100,8,PSOQSIND,.1,":"),-1)

               Begin DoDot:1

 +10               SET PSOQRAW=$GET(^OR(100,PSOQ100,8,PSOQSIND,.1,PSOQSCT,0))

 +11               NEW WORDS,COUNT,LINE,NEXTWORD

 +12               SET WORDS=$LENGTH(PSOQRAW," ")

                   SET SUB=$GET(SUB,0)+1

 +13               FOR COUNT=1:1:WORDS

                       Begin DoDot:2

 +14                       SET NEXTWORD=$PIECE(PSOQRAW," ",COUNT)

 +15                       if NEXTWORD=""

                               QUIT

 +16                       SET LINE=$GET(LINE)_NEXTWORD_" "

 +17                       IF $LENGTH($GET(LINE))>65&(COUNT'=WORDS)

                               KILL LINE

                               SET SUB=SUB+1

 +18                       SET RXS("D","**PENDING**"_PSOQPDN,SUB)=$GET(RXS("D","**PENDING**"_PSOQPDN,SUB))_NEXTWORD_" "

                       End DoDot:2

               End DoDot:1

 +19       QUIT

GETTYPE(IEN52) ;

 +1        NEW RETURN,CLASS

 +2        SET RETURN="D"

 +3        SET CLASS=$$GETCLASS(IEN52)

 +4        if $EXTRACT(CLASS,1,1)="X"

               SET RETURN="S"

 +5        if $EXTRACT(CLASS,1,2)="DX"

               SET RETURN="S"

 +6        QUIT RETURN

GETCLASS(IENRX) ;

 +1        NEW RETURN,NODE0RX,IENDRUG,NODE0DRG,NODEND50,IENCLASS,NODE0CLS,VACLASS

 +2        SET RETURN=""

 +3        SET NODE0RX=$GET(^PSRX(IENRX,0))

 +4        SET IENDRUG=$PIECE(NODE0RX,"^",6)

 +5        if +IENDRUG=0

               QUIT RETURN

 +6        SET NODE0DRG=$GET(^PSDRUG(IENDRUG,0))

 +7        SET NODEND50=$GET(^PSDRUG(IENDRUG,"ND"))

 +8        SET IENCLASS=$PIECE(NODEND50,"^",6)

 +9        if +IENCLASS=0

               QUIT RETURN

 +10       SET NODE0CLS=$GET(^PS(50.605,IENCLASS,0))

 +11       SET VACLASS=$PIECE(NODE0CLS,"^",1)

 +12       SET RETURN=VACLASS

 +13       QUIT RETURN

HD        ;

 +1        SET FN=ARLDFN

 +2        SET ARLNAME=$EXTRACT($PIECE(^DPT(ARLDFN,0),"^",1),1,28)

 +3        SET ARLSN=$PIECE(^(0),"^",9)

           SET ARLDOB=$PIECE(^(0),"^",3)

 +4        SET PHONE=$SELECT($DATA(^DPT(ARLDFN,.13)):^(.13),1:"")

 +5        SET HP=$PIECE(PHONE,"^",1)

           SET WP=$PIECE(PHONE,"^",2)

 +6        SET ADDR=$SELECT($DATA(^DPT(ARLDFN,.11)):^(.11),1:"")

 +7        IF $DATA(^DPT(ARLDFN,.121))

               IF $PIECE(^(.121),"^",9)="Y"

                   Begin DoDot:1

 +8                    SET X=$SELECT($PIECE(^(.121),"^",8):$PIECE(^(.121),"^",8),1:9999999)

 +9                    IF DT'<$PIECE(^(.121),"^",7)

                           IF DT'>X

                               Begin DoDot:2

 +10                               SET ADDR=^(.121)

 +11                               SET ADDRFL="(temporary)"

 +12                               SET HP=$PIECE(ADDR,"^",10)

                               End DoDot:2

                   End DoDot:1

 +13       SET ST=$SELECT($DATA(^DIC(5,+$PIECE(ADDR,"^",5),0)):$PIECE(^(0),"^",2),1:"UNKNOWN")

 +14       SET ADDR(4)=$PIECE(ADDR,"^",4)_", "_ST_"  "_$PIECE(ADDR,"^",6)

 +15       SET ADDR(3)=$PIECE(ADDR,"^",3)

           SET ADDR(2)=$PIECE(ADDR,"^",2)

           SET ADDR(1)=$PIECE(ADDR,"^",1)

 +16       IF ADDR(2)']""

               Begin DoDot:1

 +17               SET ADDR(2)=ADDR(3)

 +18               SET ADDR(3)=""

               End DoDot:1

HD1       ; Header for 1st page

 +1        SET ARLSITE=^PS(59,PSOSITE,0)

 +2        DO PGE

           if $DATA(GMTSQIT)

               QUIT

 +3        WRITE !,"Date: ",RPTDATE,?XPOS1,"PATIENT MEDICATION INFORMATION"

 +4        IF $DATA(PAGE)

               Begin DoDot:1

 +5                WRITE ?XPOS2,"Page: ",PAGE

 +6                SET PAGE=PAGE+1

               End DoDot:1

 +7        WRITE !,?XPOS4,"PRINTED BY THE VA MEDICAL CENTER AT: "_$PIECE($GET(^DIC(4,+$GET(^PS(59,PSOSITE,"INI")),0)),U,1)

 +8        WRITE !,?XPOS4,"FOR PRESCRIPTION REFILLS CALL ("_$PIECE(ARLSITE,U,3)_") "_$PIECE(ARLSITE,U,4)

HD2        WRITE !!,"Name: ",$EXTRACT(ARLNAME,1,40)," - ",$EXTRACT(ARLSN,6,9)

 +1        WRITE ?30," PHARMACY - ",$PIECE(ARLSITE,"^",7)," DIVISION (",$PIECE(ARLSITE,"^",3),"-",$PIECE(ARLSITE,"^",4),")",!

 +2       ;!,DRUGHDR2

           WRITE !,INSTSEP1,!,DRUGHDR1

 +3        QUIT

HD3       ;Header for subsequent pages

 +1        WRITE !,"Date: ",RPTDATE,?XPOS1,"PATIENT MEDICATION INFORMATION"

 +2        IF $DATA(PAGE)

               WRITE ?XPOS2,"Page: ",PAGE

               SET PAGE=PAGE+1

 +3        WRITE !,?XPOS4,"PRINTED BY THE VA MEDICAL CENTER AT: "_$PIECE($GET(^DIC(4,+$GET(^PS(59,PSOSITE,"INI")),0)),U,1)

 +4        WRITE !,?XPOS4,"FOR PRESCRIPTION REFILLS CALL ("_$PIECE(ARLSITE,U,3)_") "_$PIECE(ARLSITE,U,4),!

 +5        WRITE !?1,"Name: ",$EXTRACT(ARLNAME,1,40)," - ",$EXTRACT(ARLSN,6,9)

 +6        WRITE ?30," PHARMACY - ",$PIECE(ARLSITE,"^",7)," DIVISION (",$PIECE(ARLSITE,"^",3),"-",$PIECE(ARLSITE,"^",4),")",!

 +7        WRITE !,INSTSEP1

 +8        if $GET(SUPCNT)&'$GET(NVACNT)

               WRITE !,"|","SUPPLY ITEMS:"_$EXTRACT(BLNKLN,14,PGWIDTH-2)_"|",@EMPTYLN

 +9        if $GET(NVACNT)

               WRITE @EMPTYLN,!,"|","NON-VA Medications:"_$EXTRACT(BLNKLN,20,PGWIDTH-2)_"|",@EMPTYLN

 +10       if '$GET(NVACNT)&'$GET(SUPCNT)

               WRITE !,DRUGHDR1

 +11       QUIT

RE        ;Allergies

 +1        SET ARLDASH=""

           SET $PIECE(ARLDASH,"=",$EXTRACT(BLNKLN,1,PGWIDTH-10))=ARLDASH

           WRITE !,ARLDASH,!!

 +2        SET NONE="NO INFORMATION (COMPLETE SECTION BELOW)"

           SET ALFLAG=0

           DO ALL

 +3        WRITE "REACTIONS/ALLERGIES currently on file : ",$SELECT($DATA(GMRAL):"",1:NONE)

           if '$DATA(GMRAL)

               QUIT

 +4        SET X=DRUG1_FOOD

           SET DIWL=5

           SET DIWR=PGWIDTH-5

           SET DIWF="W"

           DO ^DIWP

           DO ^DIWW

 +5        QUIT

ALL       ;Gets allergy info

 +1        KILL GMRA,GMRAL

 +2        NEW IFN,DATA,VER,ARLEND

 +3        SET ARLEND=0

           SET DFN=ARLDFN

           SET GMRA="0^0^011"

           DO ^GMRADPT

           SET (DRUG1,FOOD)=""

 +4        IF $DATA(GMRAL)

               IF GMRAL=0

                   SET DRUG1="NO KNOWN ALLERGIES"

 +5        IF $DATA(GMRAL)

               IF GMRAL=1

                   SET IFN=""

FOR

                       SET IFN=$ORDER(GMRAL(IFN))

                       if IFN=""!(ARLEND)

                           QUIT

                       SET DATA=GMRAL(IFN)

                       SET AL=$PIECE(DATA,U,2)

                       SET TYPE=$PIECE(DATA,U,3)

                       SET VER=$SELECT($PIECE(DATA,U,4)=1:"V",1:"NV")

                       Begin DoDot:1

 +6                        IF $LENGTH(DRUG1)>300

                               SET DRUG1="TOO MANY TO LIST"

                               SET ARLEND=1

 +7                        if TYPE="D"

                               SET DRUG1=AL_" ("_VER_"),"_DRUG1

 +8                        if TYPE="F"

                               SET FOOD="Food Allergies on File"

                       End DoDot:1

 +9        QUIT

PSOQMCAL.m