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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOQMCAL 9801 printed Sep 23, 2025@20:09: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
