PSOORUT2 ;BIR/SAB - Build Listman Screen ;Jan 05, 2021@12:08
;;7.0;OUTPATIENT PHARMACY;**11,146,132,182,233,243,261,268,264,305,390,411,402,500,556,622,746,753**;DEC 1997;Build 53
;External reference to $$PRIAPT^SDPHARM1 supported by DBIA 4196
;External reference to ^PS(55 supported by DBIA 2228
;External reference to ^DIC(31 supported by DBIA 658
;External reference to ^ORRDI1 supported by DBIA 4659
;External reference to ^DPT(DFN,.372 supported by DBIA 1476
;External reference to ^XTMP("ORRDI" supported by DBIA 4660
;External reference to ^GMRADPT supported by DBIA 10099
;External reference to $$TERMLKUP^ORB31 supported by DBIA 5140
;External reference to $$BSA^PSSDSAPI supported by DBIA 5425
;External reference to ^ORQQVI supported by DBIA 5770
;External reference to ^ORQQLR1 supported by DBIA 5787
;External reference to ^VADPT supported by DBIA 10061
;
K ^TMP("PSOHDR",$J),^TMP("PSOPI",$J) S DFN=PSODFN D ^VADPT,ADD^VADPT
N I1,PSCNT,PSDIS,PSON,PSOTEL,PSOTMP
S ^TMP("PSOHDR",$J,1,0)=VADM(1),^TMP("PSOHDR",$J,2,0)=$P(VADM(2),"^",2)
S ^TMP("PSOHDR",$J,3,0)=$P(VADM(3),"^",2),^TMP("PSOHDR",$J,4,0)=VADM(4),^TMP("PSOHDR",$J,5,0)=$P(VADM(5),"^",2)
S POERR=1 D RE^PSODEM K POERR
S ^TMP("PSOHDR",$J,6,0)=$S($P(WT,"^",8):$P(WT,"^",9)_" ("_$P(WT,"^")_")",1:"_______ (______)")
S ^TMP("PSOHDR",$J,7,0)=$S($P(HT,"^",8):$P(HT,"^",9)_" ("_$P(HT,"^")_")",1:"_______ (______)") K VM,WT,HT S PSOHD=7
S GMRA="0^0^111" D ^GMRADPT S ^TMP("PSOHDR",$J,8,0)=+$G(GMRAL)
S $P(^TMP("PSOHDR",$J,9,0)," ",62)="ISSUE LAST REF DAY"
S ^TMP("PSOHDR",$J,10,0)=" # RX # DRUG QTY ST DATE "_$S($G(PSORFG):"RELD",1:"FILL")_" REM SUP"
;
; Display CrCl/BSA - show serum creatinine if CrCl can't be calculated
S PSOBSA=$$BSA^PSSDSAPI(DFN),PSOBSA=$P(PSOBSA,"^",3),PSOBSA=$S(PSOBSA'>0:"_______",1:$J(PSOBSA,4,2)) S ^TMP("PSOHDR",$J,12,0)=PSOBSA
S RSLT=$$CRCL(DFN)
; RSLT -- DATE^CRCL^Serum Creatinine -- Ex. 11/25/11^68.7^1.1
; Display format of CrCL and Creatinine results updated - PSO*7.0*556
I ($P($G(RSLT),"^",2)["Not Found")&($P($G(RSLT),"^",3)<.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: Not Found)"
I ($P($G(RSLT),"^",2)["Not Found")&($P($G(RSLT),"^",3)>=.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: "_$P($G(RSLT),"^",3)_"mg/dL "_$P($G(RSLT),"^")_")"
I ($P($G(RSLT),"^",2)'["Not Found")&($P($G(RSLT),"^",3)<.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: Not Found)"
I ($P($G(RSLT),"^",2)'["Not Found")&($P($G(RSLT),"^",3)>=.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_"(est.)"_" (CREAT: "_$P($G(RSLT),"^",3)_"mg/dL "_$P($G(RSLT),"^")_")"
S ^TMP("PSOHDR",$J,13,0)=$G(ZDSPL)
S ^TMP("PSOHDR",$J,14,0)=$$POSTSHRT^WVRPCOR(PSODFN)
;
D ELIG^VADPT S IEN=1,^TMP("PSOPI",$J,IEN,0)="Eligibility: "_$P(VAEL(1),"^",2)_$S(+VAEL(3):" SC%: "_$P(VAEL(3),"^",2),1:""),IEN=IEN+1
S N=0 F S N=$O(VAEL(1,N)) Q:'N S $P(^TMP("PSOPI",$J,IEN,0)," ",14)=$P(VAEL(1,N),"^",2),IEN=IEN+1
S ^TMP("PSOPI",$J,IEN,0)="",^TMP("PSOPI",$J,IEN,0)="RX PATIENT STATUS: "_$$GET1^DIQ(55,PSODFN,3),IEN=IEN+1
S ^TMP("PSOPI",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)="Disabilities: "
F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1
.S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2)
.S:$L(^TMP("PSOPI",$J,IEN,0)_PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), ")>80 IEN=IEN+1,$P(^TMP("PSOPI",$J,IEN,0)," ",14)=" "
.S ^TMP("PSOPI",$J,IEN,0)=$G(^TMP("PSOPI",$J,IEN,0))_PSDIS_"-"_PSCNT_"% ("_$S($P(I1,"^",3):"SC",1:"NSC")_"), "
S IEN=IEN+1 S ^TMP("PSOPI",$J,IEN,0)=" ",IEN=IEN+1
I +VAPA(9) S ^TMP("PSOPI",$J,IEN,0)=" (Temp Address from "_$P(VAPA(9),"^",2)_" till "_$S($P(VAPA(10),"^",2)]"":$P(VAPA(10),"^",2),1:"(no end date)")_")",IEN=IEN+1
S ^TMP("PSOPI",$J,IEN,0)=VAPA(1) S:VAPA(2)]"" IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=VAPA(2) S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=VAPA(3)
S ^TMP("PSOPI",$J,IEN,0)=^TMP("PSOPI",$J,IEN,0)_$J("",50-$L(VAPA(3)))_"HOME PHONE: "_VAPA(8)
S PSOTEL=$G(^DPT(DFN,.13))
S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=VAPA(4),^TMP("PSOPI",$J,IEN,0)=^TMP("PSOPI",$J,IEN,0)_$J("",50-$L(VAPA(4)))_"CELL PHONE: "_$P(PSOTEL,"^",4)
S PSOTMP=$P(VAPA(5),"^",2)_" "_$S(VAPA(11)]"":$P(VAPA(11),"^",2),1:VAPA(6)),IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=PSOTMP
S ^TMP("PSOPI",$J,IEN,0)=^TMP("PSOPI",$J,IEN,0)_$J("",50-$L(PSOTMP))_"WORK PHONE: "_$P(PSOTEL,"^",2)
S MAILD=+$P($G(^PS(55,DFN,0)),"^",3) D K MAILD
.S PSOTMP="Prescription Mail Delivery: "_$S(MAILD=1:"Certified Mail",MAILD=2:"DO NOT MAIL",MAILD=3:"Local - Regular Mail",MAILD=4:"Local - Certified Mail",1:"Regular Mail") S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=PSOTMP
.I MAILD<2!(MAILD>4) Q ;ONLY FOR MAIL DELIVERIES 2,3,4
.N PSOMDEXP,Y
.S Y=$P($G(^PS(55,DFN,0)),"^",5)
.I Y,Y'>DT D
..D DD^%DT S PSOMDEXP=Y
..S ^TMP("PSOPI",$J,IEN,0)=^TMP("PSOPI",$J,IEN,0)_" Expire Date: "_PSOMDEXP
I $$MAILECNT(DFN)>0 D ;p753
.N CNT
.S CNT=$$MAILECNT(DFN)
.I CNT=1 S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=" "_CNT_" Prescription Has A Mail Exemption" Q
.I CNT>1 S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=" "_CNT_" Prescriptions Have Mail Exemptions" Q
;
S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=$S($P($G(^PS(55,DFN,0)),"^",2):"Cannot use safety caps.",1:"") S $P(^TMP("PSOPI",$J,IEN,0)," ",40)=$S($P($G(^PS(55,DFN,0)),"^",4):"Dialysis Patient.",1:"")
I $G(^PS(55,DFN,1))]"" S PSON=^(1),IEN=IEN+1 D
.S ^TMP("PSOPI",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=" Outpatient Narrative: "
.F I=1:1 Q:$P(PSON," ",I,99)="" S:$L(^TMP("PSOPI",$J,IEN,0)_$P(PSON," ",I)_" ")>80 IEN=IEN+1 S ^TMP("PSOPI",$J,IEN,0)=$G(^TMP("PSOPI",$J,IEN,0))_$P(PSON," ",I)_" "
S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=" "
I $D(^PS(52.91,DFN,0)) I '$P(^(0),"^",3)!($P(^(0),"^",3)>DT) D
.S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)="Primary Care Appointment: "_$$PRIAPT^SDPHARM1(DFN)
.S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=" "
I 'GMRAL D
.S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)="Allergies: "_$S(GMRAL=0:"NKA",1:"")
.I GMRAL'=0 S PSONOAL="" D ALLERGY I PSONOAL'="" S ^TMP("PSOPI",$J,IEN,0)="Allergies: "_PSONOAL K PSONOAL
.S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=" "
.D REMOTE
.S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)="Adverse Reactions:"
D:$G(GMRAL) ^PSOORUT3
K ^UTILITY("VASD",$J),VASD S DFN=PSODFN,VASD("F")=DT,VASD("T")=9999999,VASD("W")="123456789" D SDA^VADPT K VASD I $D(^UTILITY("VASD",$J)) D
.S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)="Pending Clinic Appointments:"
.F PSOAPP=0:0 S PSOAPP=$O(^UTILITY("VASD",$J,PSOAPP)) Q:'PSOAPP S PSOAPPE=$G(^UTILITY("VASD",$J,PSOAPP,"E")),PSOAPPI=$G(^("I")) D
..K X S X2=DT,X1=$P($P($G(PSOAPPI),"^"),".") I $G(X1) D ^%DTC
..S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=" "_$P(PSOAPPE,"^")_" "_$P(PSOAPPE,"^",2)_$S($P(PSOAPPI,"^",3)["C":" *** Canceled ***",1:" ("_$G(X)_" days)")
K ^UTILITY("VASD",$J),X,PSOAPPI,PSOAPPE,PSOAPP,N,PSOBSA,ZDSPL,RSLT
S PSOPI=IEN K IEN
Q
NVAERX ; Display eRx/Non-VA Meds on file on the Header
N EPATIEN,HASACTRX,NOTE,LSTDT,I,PATSTAT
S (EPATIEN,HASACTRX)=0
F S EPATIEN=+$O(^PS(52.49,"AVPAT",+$G(PSODFN),EPATIEN)) Q:'EPATIEN D I HASACTRX Q
. S PATSTAT=$$PATSTATS^PSOERPC1(EPATIEN) F I=2:1:6 I $P(PATSTAT,"^",I) S HASACTRX=1 Q
S LSTDT=0 F I=0:0 S I=$O(^PS(55,PSODFN,"NVA",I)) Q:'I D
.Q:$P(^PS(55,PSODFN,"NVA",I,0),"^",7) Q:'$P(^PS(55,PSODFN,"NVA",I,0),"^")
.I $P(^PS(55,PSODFN,"NVA",I,0),"^",10)>+$G(LSTDT) S LSTDT=$P(^(0),"^",10)
I 'LSTDT,'HASACTRX Q
S NOTE=""
I HASACTRX S NOTE="eRx"_$S(LSTDT:" & ",1:"")
I LSTDT S NOTE=NOTE_"Non-VA"
S NOTE=NOTE_" Meds on File"
I LSTDT S NOTE=NOTE_" - Last Non-VA Entry on "_$$FMTE^XLFDT(LSTDT\1,"2Z")
;
D INSTR^VALM1(IORVON_IOUON_NOTE_IORVOFF_IOINORM,(65-$L(NOTE))\2+$S(LSTDT:14,1:9),5)
Q
REMOTE ;
I $T(HAVEHDR^ORRDI1)']"" Q
I '$$HAVEHDR^ORRDI1 Q
N PSORALG,REAC,S1,A,FILE,LEN,I
K ^TMP($J,"PSOART")
S PSORALG=1,PSORALG(1)="No remote data available"
I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) G REMOTE2
I $T(GET^ORRDI1)]"" S PSOSIEN=$G(IEN) D GET^ORRDI1(DFN,"ART") S IEN=PSOSIEN K PSOSIEN D
.I $P($G(^XTMP("ORRDI","ART",DFN,0)),"^",3)=0 S PSORALG(1)="No remote allergies"
.S S1=0,LEN=65,PSORALG=1,PSORALG(1)="" F S S1=$O(^XTMP("ORRDI","ART",DFN,S1)) Q:'S1 D
..S A=$G(^XTMP("ORRDI","ART",DFN,S1,"GMRALLERGY",0))
..S REAC=$P(A,"^",2) Q:REAC=""
..S FILE=$P($P(A,"^",3),"99VA",2)
..I FILE'=50.6,FILE'=120.82,FILE'=50.605,FILE'=50.416 Q
..S ^TMP($J,"PSOART",REAC)=""
.S REAC="" F S REAC=$O(^TMP($J,"PSOART",REAC)) Q:REAC="" D
..I $L(PSORALG(PSORALG))+$L(REAC)<LEN S PSORALG(PSORALG)=PSORALG(PSORALG)_REAC_", " Q
..S PSORALG=PSORALG+1,PSORALG(PSORALG)=" "_REAC_", ",LEN=76
.I PSORALG(PSORALG)]"",$E(PSORALG(PSORALG),$L(PSORALG(PSORALG)))="," S PSORALG(PSORALG)=$E(PSORALG(PSORALG),1,$L(PSORALG(PSORALG))-1)
REMOTE2 ;
S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=" Remote: "_$G(PSORALG(1)) D
.F I=2:1:PSORALG S IEN=IEN+1,^TMP("PSOPI",$J,IEN,0)=PSORALG(I)
K ^TMP($J,"PSOART")
Q
;
ALLERGY ;ALLERGIES & REACTIONS
N GMRA,GMRAL,PSORY,ALCNT,EEE,PSOLG,PSOLGA,TEXT,CCC,CCC2,LENGTH
K ^TMP($J,"PSOALWA")
I '$D(DFN) S DFN=PSODFN
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
S TEXT=^TMP($J,"PSOAPT",1) D CHKNO(TEXT)
F CCC=3,4,5 I '$O(^TMP($J,"PSOAPT",CCC,0)) K ^TMP($J,"PSOAPT",CCC)
D PSONOAL
I CCC="NKA" S ^TMP($J,"PSOAPT",2,1)="No Known Allergies" K ^TMP($J,"PSOAPT",3)
N OUT 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 TEXT="No Allergy Assessment" S PSONOAL=TEXT Q
.S (TEXT,CCC2)="",LENGTH=0
.F S CCC2=$O(^TMP($J,"PSOAPT",CCC,CCC2)) Q:CCC2="" S TEXT=^(CCC2) D CHKNO(TEXT)
K ^TMP($J,"PSOALWA"),^TMP($J,"PSOAPT")
Q
CHKNO(T) ;
I T="No Allergy Assessment" S PSONOAL=T
Q
PSONOAL ;
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 Allergy Assessment" K ^TMP($J,"PSOAPT",3)
Q
CRCL(DFN) ;
N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW,X1,X2,RSLT,PSCR,PSRW,ABW,ZHT,PSRH,PSCXTL,PSCXTLS,SCR,SCRD,OCXT,OCXTS,SCRV,ZAGE,ZSERUM,SEX
S RSLT="0^<Not Found>"
S PSCR="^^^^^^0"
S PSCXTL="" Q:'$$TERMLKUP^ORB31(.PSCXTL,"SERUM CREATININE") RSLT
S PSCXTLS="" Q:'$$TERMLKUP^ORB31(.PSCXTLS,"SERUM SPECIMEN") RSLT
S SCR="",OCXT=0 F S OCXT=$O(PSCXTL(OCXT)) Q:'OCXT D
.S OCXTS=0 F S OCXTS=$O(PSCXTLS(OCXTS)) Q:'OCXTS D
..S SCR=$$LOCL^ORQQLR1(DFN,$P(PSCXTL(OCXT),U),$P(PSCXTLS(OCXTS),U))
..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR
S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT
S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT
S RSLT=SCRD_"^<Not Found>^"_$P($G(SCR),"^",3)
S X1=$P(RSLT,"^"),X2=$$FMTE^XLFDT(X1,"2M"),$P(RSLT,"^")=$P(X2,"@") K X1,X2
D VITAL^ORQQVI("WEIGHT","WT",DFN,.PSRW,0,"",$$NOW^XLFDT)
Q:'$D(PSRW) RSLT
S ABW=$P(PSRW(1),U,3) Q:+$G(ABW)<1 RSLT
S ABW=ABW/2.2046226 ;ABW (actual body weight) in kg; changed 2.2 to 2.2046226 per CQ 10637 ; PSO 402
D VITAL^ORQQVI("HEIGHT","HT",DFN,.PSRH,0,"",$$NOW^XLFDT)
Q:'$D(PSRH) RSLT
S ZHT=$P(PSRH(1),U,3) Q:+$G(ZHT)<1 RSLT
N VADM D DEM^VADPT S ZAGE=$G(VADM(4)) Q:'$L(ZAGE) RSLT
;S ZAGE=$$AGE^ORQPTQ4(DFN) Q:'ZAGE RSLT
S SEX=$P($G(VADM(5)),"^") Q:'$L(SEX) RSLT
;S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT
I '$G(ABW)!($G(ZHT)<1)!'$G(ZAGE)!'$D(SEX) Q RSLT
S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT
S HTGT60=$S(ZHT>60:(ZHT-60)*2.3,1:0) ;if ht > 60 inches
I HTGT60>0 D
.S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60) ;Ideal Body Weight
.S BWRATIO=(ABW/IBW) ;body weight ratio
.S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0)
.S LOWBW=$S(IBW<ABW:IBW,1:ABW)
.I BWRATIO>1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW)
.E S ADJBW=LOWBW
I +$G(ADJBW)<1 D
.S ADJBW=ABW
S CRCL=(((140-ZAGE)*ADJBW)/(SCRV*72))
S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1)
S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1)
S X1=$P(RSLT,"^"),X2=$$FMTE^XLFDT(X1,"2M"),$P(RSLT,"^")=$P(X2,"@") K X1,X2
S $P(RSLT,"^",3)=$P($G(SCR),"^",3)
K HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW,X1,X2,PSCR,PSRW,ABW,ZHT,PSRH,ZAGE,PSCXTL,PSCXTLS,SCR,OCXT,OCXTS,SCRV,CRCL,ZSERUM
Q RSLT
;
MAILECNT(PSODFN) ;entry for mail exemption count p753
;called from PSOORUT2 above to count the number of mail exemptions for display on patient information
;PSODFN - Patient IEN
N RXIEN,STA,DRUG,X1,X2,PSOSD,PSODTCUT,X,Y,CNT
S CNT=0
S X2=-120,X1=DT D C^%DTC S PSODTCUT=X ;date cutoff for prescriptions
D ^PSOBUILD ;build psosd array
S STA="" F S STA=$O(PSOSD(STA)) Q:STA="" I "^ACTIVE^NON-VERIFIED^REFILL^HOLD^DRUG INTERACTIONS^SUSPENDED^"[STA D
.S DRUG="" F S DRUG=$O(PSOSD(STA,DRUG)) Q:DRUG="" D
..S RXIEN=+PSOSD(STA,DRUG)
..I $$GET1^DIQ(52,RXIEN,100.2,"I")']"" Q
..S CNT=CNT+1
Q CNT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOORUT2 14323 printed Sep 23, 2025@20:08:51 Page 2
PSOORUT2 ;BIR/SAB - Build Listman Screen ;Jan 05, 2021@12:08
+1 ;;7.0;OUTPATIENT PHARMACY;**11,146,132,182,233,243,261,268,264,305,390,411,402,500,556,622,746,753**;DEC 1997;Build 53
+2 ;External reference to $$PRIAPT^SDPHARM1 supported by DBIA 4196
+3 ;External reference to ^PS(55 supported by DBIA 2228
+4 ;External reference to ^DIC(31 supported by DBIA 658
+5 ;External reference to ^ORRDI1 supported by DBIA 4659
+6 ;External reference to ^DPT(DFN,.372 supported by DBIA 1476
+7 ;External reference to ^XTMP("ORRDI" supported by DBIA 4660
+8 ;External reference to ^GMRADPT supported by DBIA 10099
+9 ;External reference to $$TERMLKUP^ORB31 supported by DBIA 5140
+10 ;External reference to $$BSA^PSSDSAPI supported by DBIA 5425
+11 ;External reference to ^ORQQVI supported by DBIA 5770
+12 ;External reference to ^ORQQLR1 supported by DBIA 5787
+13 ;External reference to ^VADPT supported by DBIA 10061
+14 ;
+15 KILL ^TMP("PSOHDR",$JOB),^TMP("PSOPI",$JOB)
SET DFN=PSODFN
DO ^VADPT
DO ADD^VADPT
+16 NEW I1,PSCNT,PSDIS,PSON,PSOTEL,PSOTMP
+17 SET ^TMP("PSOHDR",$JOB,1,0)=VADM(1)
SET ^TMP("PSOHDR",$JOB,2,0)=$PIECE(VADM(2),"^",2)
+18 SET ^TMP("PSOHDR",$JOB,3,0)=$PIECE(VADM(3),"^",2)
SET ^TMP("PSOHDR",$JOB,4,0)=VADM(4)
SET ^TMP("PSOHDR",$JOB,5,0)=$PIECE(VADM(5),"^",2)
+19 SET POERR=1
DO RE^PSODEM
KILL POERR
+20 SET ^TMP("PSOHDR",$JOB,6,0)=$SELECT($PIECE(WT,"^",8):$PIECE(WT,"^",9)_" ("_$PIECE(WT,"^")_")",1:"_______ (______)")
+21 SET ^TMP("PSOHDR",$JOB,7,0)=$SELECT($PIECE(HT,"^",8):$PIECE(HT,"^",9)_" ("_$PIECE(HT,"^")_")",1:"_______ (______)")
KILL VM,WT,HT
SET PSOHD=7
+22 SET GMRA="0^0^111"
DO ^GMRADPT
SET ^TMP("PSOHDR",$JOB,8,0)=+$GET(GMRAL)
+23 SET $PIECE(^TMP("PSOHDR",$JOB,9,0)," ",62)="ISSUE LAST REF DAY"
+24 SET ^TMP("PSOHDR",$JOB,10,0)=" # RX # DRUG QTY ST DATE "_$SELECT($GET(PSORFG):"RELD",1:"FILL")_" REM SUP"
+25 ;
+26 ; Display CrCl/BSA - show serum creatinine if CrCl can't be calculated
+27 SET PSOBSA=$$BSA^PSSDSAPI(DFN)
SET PSOBSA=$PIECE(PSOBSA,"^",3)
SET PSOBSA=$SELECT(PSOBSA'>0:"_______",1:$JUSTIFY(PSOBSA,4,2))
SET ^TMP("PSOHDR",$JOB,12,0)=PSOBSA
+28 SET RSLT=$$CRCL(DFN)
+29 ; RSLT -- DATE^CRCL^Serum Creatinine -- Ex. 11/25/11^68.7^1.1
+30 ; Display format of CrCL and Creatinine results updated - PSO*7.0*556
+31 IF ($PIECE($GET(RSLT),"^",2)["Not Found")&($PIECE($GET(RSLT),"^",3)<.01)
SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: Not Found)"
+32 IF ($PIECE($GET(RSLT),"^",2)["Not Found")&($PIECE($GET(RSLT),"^",3)>=.01)
SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: "_$PIECE($GET(RSLT),"^",3)_"mg/dL "_$PIECE($GET(RSLT),"^")_")"
+33 IF ($PIECE($GET(RSLT),"^",2)'["Not Found")&($PIECE($GET(RSLT),"^",3)<.01)
SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: Not Found)"
+34 IF ($PIECE($GET(RSLT),"^",2)'["Not Found")&($PIECE($GET(RSLT),"^",3)>=.01)
SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_"(est.)"_" (CREAT: "_$PIECE($GET(RSLT),"^",3)_"mg/dL "_$PIECE($GET(RSLT),"^")_")"
+35 SET ^TMP("PSOHDR",$JOB,13,0)=$GET(ZDSPL)
+36 SET ^TMP("PSOHDR",$JOB,14,0)=$$POSTSHRT^WVRPCOR(PSODFN)
+37 ;
+38 DO ELIG^VADPT
SET IEN=1
SET ^TMP("PSOPI",$JOB,IEN,0)="Eligibility: "_$PIECE(VAEL(1),"^",2)_$SELECT(+VAEL(3):" SC%: "_$PIECE(VAEL(3),"^",2),1:"")
SET IEN=IEN+1
+39 SET N=0
FOR
SET N=$ORDER(VAEL(1,N))
if 'N
QUIT
SET $PIECE(^TMP("PSOPI",$JOB,IEN,0)," ",14)=$PIECE(VAEL(1,N),"^",2)
SET IEN=IEN+1
+40 SET ^TMP("PSOPI",$JOB,IEN,0)=""
SET ^TMP("PSOPI",$JOB,IEN,0)="RX PATIENT STATUS: "_$$GET1^DIQ(55,PSODFN,3)
SET IEN=IEN+1
+41 SET ^TMP("PSOPI",$JOB,IEN,0)=" "
SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)="Disabilities: "
+42 FOR I=0:0
SET I=$ORDER(^DPT(DFN,.372,I))
if 'I
QUIT
SET I1=$SELECT($DATA(^DPT(DFN,.372,I,0)):^(0),1:"")
if +I1
Begin DoDot:1
+43 SET PSDIS=$SELECT($PIECE($GET(^DIC(31,+I1,0)),"^")]""&($PIECE($GET(^(0)),"^",4)']""):$PIECE(^(0),"^"),$PIECE($GET(^DIC(31,+I1,0)),"^",4)]"":$PIECE(^(0),"^",4),1:"")
SET PSCNT=$PIECE(I1,"^",2)
+44 if $LENGTH(^TMP("PSOPI",$JOB,IEN,0)_PSDIS_"-"_PSCNT_"% ("_$SELECT($PIECE(I1,"^",3)
SET IEN=IEN+1
SET $PIECE(^TMP("PSOPI",$JOB,IEN,0)," ",14)=" "
+45 SET ^TMP("PSOPI",$JOB,IEN,0)=$GET(^TMP("PSOPI",$JOB,IEN,0))_PSDIS_"-"_PSCNT_"% ("_$SELECT($PIECE(I1,"^",3):"SC",1:"NSC")_"), "
End DoDot:1
+46 SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=" "
SET IEN=IEN+1
+47 IF +VAPA(9)
SET ^TMP("PSOPI",$JOB,IEN,0)=" (Temp Address from "_$PIECE(VAPA(9),"^",2)_" till "_$SELECT($PIECE(VAPA(10),"^",2)]"":$PIECE(VAPA(10),"^",2),1:"(no end date)")_")"
SET IEN=IEN+1
+48 SET ^TMP("PSOPI",$JOB,IEN,0)=VAPA(1)
if VAPA(2)]""
SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=VAPA(2)
SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=VAPA(3)
+49 SET ^TMP("PSOPI",$JOB,IEN,0)=^TMP("PSOPI",$JOB,IEN,0)_$JUSTIFY("",50-$LENGTH(VAPA(3)))_"HOME PHONE: "_VAPA(8)
+50 SET PSOTEL=$GET(^DPT(DFN,.13))
+51 SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=VAPA(4)
SET ^TMP("PSOPI",$JOB,IEN,0)=^TMP("PSOPI",$JOB,IEN,0)_$JUSTIFY("",50-$LENGTH(VAPA(4)))_"CELL PHONE: "_$PIECE(PSOTEL,"^",4)
+52 SET PSOTMP=$PIECE(VAPA(5),"^",2)_" "_$SELECT(VAPA(11)]"":$PIECE(VAPA(11),"^",2),1:VAPA(6))
SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=PSOTMP
+53 SET ^TMP("PSOPI",$JOB,IEN,0)=^TMP("PSOPI",$JOB,IEN,0)_$JUSTIFY("",50-$LENGTH(PSOTMP))_"WORK PHONE: "_$PIECE(PSOTEL,"^",2)
+54 SET MAILD=+$PIECE($GET(^PS(55,DFN,0)),"^",3)
Begin DoDot:1
+55 SET PSOTMP="Prescription Mail Delivery: "_$SELECT(MAILD=1:"Certified Mail",MAILD=2:"DO NOT MAIL",MAILD=3:"Local - Regular Mail",MAILD=4:"Local - Certified Mail",1:"Regular Mail")
SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=PSOTMP
+56 ;ONLY FOR MAIL DELIVERIES 2,3,4
IF MAILD<2!(MAILD>4)
QUIT
+57 NEW PSOMDEXP,Y
+58 SET Y=$PIECE($GET(^PS(55,DFN,0)),"^",5)
+59 IF Y
IF Y'>DT
Begin DoDot:2
+60 DO DD^%DT
SET PSOMDEXP=Y
+61 SET ^TMP("PSOPI",$JOB,IEN,0)=^TMP("PSOPI",$JOB,IEN,0)_" Expire Date: "_PSOMDEXP
End DoDot:2
End DoDot:1
KILL MAILD
+62 ;p753
IF $$MAILECNT(DFN)>0
Begin DoDot:1
+63 NEW CNT
+64 SET CNT=$$MAILECNT(DFN)
+65 IF CNT=1
SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=" "_CNT_" Prescription Has A Mail Exemption"
QUIT
+66 IF CNT>1
SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=" "_CNT_" Prescriptions Have Mail Exemptions"
QUIT
End DoDot:1
+67 ;
+68 SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=$SELECT($PIECE($GET(^PS(55,DFN,0)),"^",2):"Cannot use safety caps.",1:"")
SET $PIECE(^TMP("PSOPI",$JOB,IEN,0)," ",40)=$SELECT($PIECE($GET(^PS(55,DFN,0)),"^",4):"Dialysis Patient.",1:"")
+69 IF $GET(^PS(55,DFN,1))]""
SET PSON=^(1)
SET IEN=IEN+1
Begin DoDot:1
+70 SET ^TMP("PSOPI",$JOB,IEN,0)=" "
SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=" Outpatient Narrative: "
+71 FOR I=1:1
if $PIECE(PSON," ",I,99)=""
QUIT
if $LENGTH(^TMP("PSOPI",$JOB,IEN,0)_$PIECE(PSON," ",I)_" ")>80
SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=$GET(^TMP("PSOPI",$JOB,IEN,0))_$PIECE(PSON," ",I)_" "
End DoDot:1
+72 SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=" "
+73 IF $DATA(^PS(52.91,DFN,0))
IF '$PIECE(^(0),"^",3)!($PIECE(^(0),"^",3)>DT)
Begin DoDot:1
+74 SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)="Primary Care Appointment: "_$$PRIAPT^SDPHARM1(DFN)
+75 SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=" "
End DoDot:1
+76 IF 'GMRAL
Begin DoDot:1
+77 SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)="Allergies: "_$SELECT(GMRAL=0:"NKA",1:"")
+78 IF GMRAL'=0
SET PSONOAL=""
DO ALLERGY
IF PSONOAL'=""
SET ^TMP("PSOPI",$JOB,IEN,0)="Allergies: "_PSONOAL
KILL PSONOAL
+79 SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=" "
+80 DO REMOTE
+81 SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)="Adverse Reactions:"
End DoDot:1
+82 if $GET(GMRAL)
DO ^PSOORUT3
+83 KILL ^UTILITY("VASD",$JOB),VASD
SET DFN=PSODFN
SET VASD("F")=DT
SET VASD("T")=9999999
SET VASD("W")="123456789"
DO SDA^VADPT
KILL VASD
IF $DATA(^UTILITY("VASD",$JOB))
Begin DoDot:1
+84 SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=" "
SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)="Pending Clinic Appointments:"
+85 FOR PSOAPP=0:0
SET PSOAPP=$ORDER(^UTILITY("VASD",$JOB,PSOAPP))
if 'PSOAPP
QUIT
SET PSOAPPE=$GET(^UTILITY("VASD",$JOB,PSOAPP,"E"))
SET PSOAPPI=$GET(^("I"))
Begin DoDot:2
+86 KILL X
SET X2=DT
SET X1=$PIECE($PIECE($GET(PSOAPPI),"^"),".")
IF $GET(X1)
DO ^%DTC
+87 SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=" "_$PIECE(PSOAPPE,"^")_" "_$PIECE(PSOAPPE,"^",2)_$SELECT($PIECE(PSOAPPI,"^",3)["C":" *** Canceled ***",1:" ("_$GET(X)_" days)")
End DoDot:2
End DoDot:1
+88 KILL ^UTILITY("VASD",$JOB),X,PSOAPPI,PSOAPPE,PSOAPP,N,PSOBSA,ZDSPL,RSLT
+89 SET PSOPI=IEN
KILL IEN
+90 QUIT
NVAERX ; Display eRx/Non-VA Meds on file on the Header
+1 NEW EPATIEN,HASACTRX,NOTE,LSTDT,I,PATSTAT
+2 SET (EPATIEN,HASACTRX)=0
+3 FOR
SET EPATIEN=+$ORDER(^PS(52.49,"AVPAT",+$GET(PSODFN),EPATIEN))
if 'EPATIEN
QUIT
Begin DoDot:1
+4 SET PATSTAT=$$PATSTATS^PSOERPC1(EPATIEN)
FOR I=2:1:6
IF $PIECE(PATSTAT,"^",I)
SET HASACTRX=1
QUIT
End DoDot:1
IF HASACTRX
QUIT
+5 SET LSTDT=0
FOR I=0:0
SET I=$ORDER(^PS(55,PSODFN,"NVA",I))
if 'I
QUIT
Begin DoDot:1
+6 if $PIECE(^PS(55,PSODFN,"NVA",I,0),"^",7)
QUIT
if '$PIECE(^PS(55,PSODFN,"NVA",I,0),"^")
QUIT
+7 IF $PIECE(^PS(55,PSODFN,"NVA",I,0),"^",10)>+$GET(LSTDT)
SET LSTDT=$PIECE(^(0),"^",10)
End DoDot:1
+8 IF 'LSTDT
IF 'HASACTRX
QUIT
+9 SET NOTE=""
+10 IF HASACTRX
SET NOTE="eRx"_$SELECT(LSTDT:" & ",1:"")
+11 IF LSTDT
SET NOTE=NOTE_"Non-VA"
+12 SET NOTE=NOTE_" Meds on File"
+13 IF LSTDT
SET NOTE=NOTE_" - Last Non-VA Entry on "_$$FMTE^XLFDT(LSTDT\1,"2Z")
+14 ;
+15 DO INSTR^VALM1(IORVON_IOUON_NOTE_IORVOFF_IOINORM,(65-$LENGTH(NOTE))\2+$SELECT(LSTDT:14,1:9),5)
+16 QUIT
REMOTE ;
+1 IF $TEXT(HAVEHDR^ORRDI1)']""
QUIT
+2 IF '$$HAVEHDR^ORRDI1
QUIT
+3 NEW PSORALG,REAC,S1,A,FILE,LEN,I
+4 KILL ^TMP($JOB,"PSOART")
+5 SET PSORALG=1
SET PSORALG(1)="No remote data available"
+6 IF $DATA(^XTMP("ORRDI","OUTAGE INFO","DOWN"))
GOTO REMOTE2
+7 IF $TEXT(GET^ORRDI1)]""
SET PSOSIEN=$GET(IEN)
DO GET^ORRDI1(DFN,"ART")
SET IEN=PSOSIEN
KILL PSOSIEN
Begin DoDot:1
+8 IF $PIECE($GET(^XTMP("ORRDI","ART",DFN,0)),"^",3)=0
SET PSORALG(1)="No remote allergies"
+9 SET S1=0
SET LEN=65
SET PSORALG=1
SET PSORALG(1)=""
FOR
SET S1=$ORDER(^XTMP("ORRDI","ART",DFN,S1))
if 'S1
QUIT
Begin DoDot:2
+10 SET A=$GET(^XTMP("ORRDI","ART",DFN,S1,"GMRALLERGY",0))
+11 SET REAC=$PIECE(A,"^",2)
if REAC=""
QUIT
+12 SET FILE=$PIECE($PIECE(A,"^",3),"99VA",2)
+13 IF FILE'=50.6
IF FILE'=120.82
IF FILE'=50.605
IF FILE'=50.416
QUIT
+14 SET ^TMP($JOB,"PSOART",REAC)=""
End DoDot:2
+15 SET REAC=""
FOR
SET REAC=$ORDER(^TMP($JOB,"PSOART",REAC))
if REAC=""
QUIT
Begin DoDot:2
+16 IF $LENGTH(PSORALG(PSORALG))+$LENGTH(REAC)<LEN
SET PSORALG(PSORALG)=PSORALG(PSORALG)_REAC_", "
QUIT
+17 SET PSORALG=PSORALG+1
SET PSORALG(PSORALG)=" "_REAC_", "
SET LEN=76
End DoDot:2
+18 IF PSORALG(PSORALG)]""
IF $EXTRACT(PSORALG(PSORALG),$LENGTH(PSORALG(PSORALG)))=","
SET PSORALG(PSORALG)=$EXTRACT(PSORALG(PSORALG),1,$LENGTH(PSORALG(PSORALG))-1)
End DoDot:1
REMOTE2 ;
+1 SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=" Remote: "_$GET(PSORALG(1))
Begin DoDot:1
+2 FOR I=2:1:PSORALG
SET IEN=IEN+1
SET ^TMP("PSOPI",$JOB,IEN,0)=PSORALG(I)
End DoDot:1
+3 KILL ^TMP($JOB,"PSOART")
+4 QUIT
+5 ;
ALLERGY ;ALLERGIES & REACTIONS
+1 NEW GMRA,GMRAL,PSORY,ALCNT,EEE,PSOLG,PSOLGA,TEXT,CCC,CCC2,LENGTH
+2 KILL ^TMP($JOB,"PSOALWA")
+3 IF '$DATA(DFN)
SET DFN=PSODFN
+4 SET GMRA="0^0^111"
DO ^GMRADPT
+5 IF $GET(GMRAL)
SET PSORY=0
FOR
SET PSORY=$ORDER(GMRAL(PSORY))
if 'PSORY
QUIT
SET ^TMP($JOB,"PSOALWA",$SELECT($PIECE(GMRAL(PSORY),"^",4):1,1:2),$SELECT('$PIECE(GMRAL(PSORY),"^",5):1,1:2),$PIECE(GMRAL(PSORY),"^",7),$PIECE(GMRAL(PSORY),"^",2))=""
+6 SET ^TMP($JOB,"PSOAPT",1)=$GET(PNM)_" "_$GET(SSNP)
SET ^(2)="Verified Allergies"
+7 SET ALCNT=0
SET EEE=0
SET (PSOLG,PSOLGA)=""
FOR
SET PSOLG=$ORDER(^TMP($JOB,"PSOALWA",1,1,PSOLG))
if PSOLG=""
QUIT
FOR
SET PSOLGA=$ORDER(^TMP($JOB,"PSOALWA",1,1,PSOLG,PSOLGA))
if PSOLGA=""
QUIT
SET EEE=1
SET ALCNT=ALCNT+1
SET ^TMP($JOB,"PSOAPT",2,ALCNT)=PSOLGA
+8 IF 'EEE
IF $GET(GMRAL)=0
SET ALCNT=ALCNT+1
SET ^TMP($JOB,"PSOAPT",2,ALCNT)="NKA"
+9 SET ALCNT=0
SET ^TMP($JOB,"PSOAPT",3)="Non-Verified Allergies"
+10 SET EEE=0
SET (PSOLG,PSOLGA)=""
FOR
SET PSOLG=$ORDER(^TMP($JOB,"PSOALWA",2,1,PSOLG))
if PSOLG=""
QUIT
FOR
SET PSOLGA=$ORDER(^TMP($JOB,"PSOALWA",2,1,PSOLG,PSOLGA))
if PSOLGA=""
QUIT
SET EEE=EEE+1
SET ALCNT=ALCNT+1
SET ^TMP($JOB,"PSOAPT",3,ALCNT)=PSOLGA
+11 IF 'EEE
IF $GET(GMRAL)=0
SET ALCNT=ALCNT+1
SET ^TMP($JOB,"PSOAPT",3,ALCNT)="NKA"
+12 SET ALCNT=0
SET ^TMP($JOB,"PSOAPT",4)="Verified Adverse Reactions"
+13 SET (PSOLG,PSOLGA)=""
FOR
SET PSOLG=$ORDER(^TMP($JOB,"PSOALWA",1,2,PSOLG))
if PSOLG=""
QUIT
FOR
SET PSOLGA=$ORDER(^TMP($JOB,"PSOALWA",1,2,PSOLG,PSOLGA))
if PSOLGA=""
QUIT
SET ALCNT=ALCNT+1
SET ^TMP($JOB,"PSOAPT",4,ALCNT)=PSOLGA
+14 SET ALCNT=0
SET ^TMP($JOB,"PSOAPT",5)="Non-Verified Adverse Reactions"
+15 SET (PSOLG,PSOLGA)=""
FOR
SET PSOLG=$ORDER(^TMP($JOB,"PSOALWA",2,2,PSOLG))
if PSOLG=""
QUIT
FOR
SET PSOLGA=$ORDER(^TMP($JOB,"PSOALWA",2,2,PSOLG,PSOLGA))
if PSOLGA=""
QUIT
SET ALCNT=ALCNT+1
SET ^TMP($JOB,"PSOAPT",5,ALCNT)=PSOLGA
+16 SET TEXT=^TMP($JOB,"PSOAPT",1)
DO CHKNO(TEXT)
+17 FOR CCC=3,4,5
IF '$ORDER(^TMP($JOB,"PSOAPT",CCC,0))
KILL ^TMP($JOB,"PSOAPT",CCC)
+18 DO PSONOAL
+19 IF CCC="NKA"
SET ^TMP($JOB,"PSOAPT",2,1)="No Known Allergies"
KILL ^TMP($JOB,"PSOAPT",3)
+20 NEW OUT
SET CCC=1
SET OUT=0
+21 FOR
SET CCC=$ORDER(^TMP($JOB,"PSOAPT",CCC))
if CCC=""
QUIT
Begin DoDot:1
+22 SET TEXT=$GET(^TMP($JOB,"PSOAPT",CCC))
+23 IF TEXT="No Allergy Assessment"
SET PSONOAL=TEXT
QUIT
+24 SET (TEXT,CCC2)=""
SET LENGTH=0
+25 FOR
SET CCC2=$ORDER(^TMP($JOB,"PSOAPT",CCC,CCC2))
if CCC2=""
QUIT
SET TEXT=^(CCC2)
DO CHKNO(TEXT)
End DoDot:1
if OUT
QUIT
+26 KILL ^TMP($JOB,"PSOALWA"),^TMP($JOB,"PSOAPT")
+27 QUIT
CHKNO(T) ;
+1 IF T="No Allergy Assessment"
SET PSONOAL=T
+2 QUIT
PSONOAL ;
+1 NEW FLG3,FLG4,FLG5
+2 SET CCC=$GET(^TMP($JOB,"PSOAPT",2,1))
+3 SET FLG3=$GET(^TMP($JOB,"PSOAPT",3,1))
+4 SET FLG4=$GET(^TMP($JOB,"PSOAPT",4,1))
+5 SET FLG5=$GET(^TMP($JOB,"PSOAPT",5,1))
+6 IF CCC=""
IF FLG3=""
IF FLG4=""
IF FLG5=""
SET ^TMP($JOB,"PSOAPT",2,1)="No Allergy Assessment"
KILL ^TMP($JOB,"PSOAPT",3)
+7 QUIT
CRCL(DFN) ;
+1 NEW HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW,X1,X2,RSLT,PSCR,PSRW,ABW,ZHT,PSRH,PSCXTL,PSCXTLS,SCR,SCRD,OCXT,OCXTS,SCRV,ZAGE,ZSERUM,SEX
+2 SET RSLT="0^<Not Found>"
+3 SET PSCR="^^^^^^0"
+4 SET PSCXTL=""
if '$$TERMLKUP^ORB31(.PSCXTL,"SERUM CREATININE")
QUIT RSLT
+5 SET PSCXTLS=""
if '$$TERMLKUP^ORB31(.PSCXTLS,"SERUM SPECIMEN")
QUIT RSLT
+6 SET SCR=""
SET OCXT=0
FOR
SET OCXT=$ORDER(PSCXTL(OCXT))
if 'OCXT
QUIT
Begin DoDot:1
+7 SET OCXTS=0
FOR
SET OCXTS=$ORDER(PSCXTLS(OCXTS))
if 'OCXTS
QUIT
Begin DoDot:2
+8 SET SCR=$$LOCL^ORQQLR1(DFN,$PIECE(PSCXTL(OCXT),U),$PIECE(PSCXTLS(OCXTS),U))
+9 IF $PIECE(SCR,U,7)>$PIECE(PSCR,U,7)
SET PSCR=SCR
End DoDot:2
End DoDot:1
+10 SET SCR=PSCR
SET SCRV=$PIECE(SCR,U,3)
if +$GET(SCRV)<.01
QUIT RSLT
+11 SET SCRD=$PIECE(SCR,U,7)
if '$LENGTH(SCRD)
QUIT RSLT
+12 SET RSLT=SCRD_"^<Not Found>^"_$PIECE($GET(SCR),"^",3)
+13 SET X1=$PIECE(RSLT,"^")
SET X2=$$FMTE^XLFDT(X1,"2M")
SET $PIECE(RSLT,"^")=$PIECE(X2,"@")
KILL X1,X2
+14 DO VITAL^ORQQVI("WEIGHT","WT",DFN,.PSRW,0,"",$$NOW^XLFDT)
+15 if '$DATA(PSRW)
QUIT RSLT
+16 SET ABW=$PIECE(PSRW(1),U,3)
if +$GET(ABW)<1
QUIT RSLT
+17 ;ABW (actual body weight) in kg; changed 2.2 to 2.2046226 per CQ 10637 ; PSO 402
SET ABW=ABW/2.2046226
+18 DO VITAL^ORQQVI("HEIGHT","HT",DFN,.PSRH,0,"",$$NOW^XLFDT)
+19 if '$DATA(PSRH)
QUIT RSLT
+20 SET ZHT=$PIECE(PSRH(1),U,3)
if +$GET(ZHT)<1
QUIT RSLT
+21 NEW VADM
DO DEM^VADPT
SET ZAGE=$GET(VADM(4))
if '$LENGTH(ZAGE)
QUIT RSLT
+22 ;S ZAGE=$$AGE^ORQPTQ4(DFN) Q:'ZAGE RSLT
+23 SET SEX=$PIECE($GET(VADM(5)),"^")
if '$LENGTH(SEX)
QUIT RSLT
+24 ;S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT
+25 IF '$GET(ABW)!($GET(ZHT)<1)!'$GET(ZAGE)!'$DATA(SEX)
QUIT RSLT
+26 SET SCRD=$PIECE(SCR,U,7)
if '$LENGTH(SCRD)
QUIT RSLT
+27 ;if ht > 60 inches
SET HTGT60=$SELECT(ZHT>60:(ZHT-60)*2.3,1:0)
+28 IF HTGT60>0
Begin DoDot:1
+29 ;Ideal Body Weight
SET IBW=$SELECT(SEX="M":50+HTGT60,1:45.5+HTGT60)
+30 ;body weight ratio
SET BWRATIO=(ABW/IBW)
+31 SET BWDIFF=$SELECT(ABW>IBW:ABW-IBW,1:0)
+32 SET LOWBW=$SELECT(IBW<ABW:IBW,1:ABW)
+33 IF BWRATIO>1.3
IF (BWDIFF>0)
SET ADJBW=((0.3*BWDIFF)+IBW)
+34 IF '$TEST
SET ADJBW=LOWBW
End DoDot:1
+35 IF +$GET(ADJBW)<1
Begin DoDot:1
+36 SET ADJBW=ABW
End DoDot:1
+37 SET CRCL=(((140-ZAGE)*ADJBW)/(SCRV*72))
+38 if SEX="M"
SET RSLT=SCRD_U_$JUSTIFY(CRCL,1,1)
+39 if SEX="F"
SET RSLT=SCRD_U_$JUSTIFY((CRCL*.85),1,1)
+40 SET X1=$PIECE(RSLT,"^")
SET X2=$$FMTE^XLFDT(X1,"2M")
SET $PIECE(RSLT,"^")=$PIECE(X2,"@")
KILL X1,X2
+41 SET $PIECE(RSLT,"^",3)=$PIECE($GET(SCR),"^",3)
+42 KILL HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW,X1,X2,PSCR,PSRW,ABW,ZHT,PSRH,ZAGE,PSCXTL,PSCXTLS,SCR,OCXT,OCXTS,SCRV,CRCL,ZSERUM
+43 QUIT RSLT
+44 ;
MAILECNT(PSODFN) ;entry for mail exemption count p753
+1 ;called from PSOORUT2 above to count the number of mail exemptions for display on patient information
+2 ;PSODFN - Patient IEN
+3 NEW RXIEN,STA,DRUG,X1,X2,PSOSD,PSODTCUT,X,Y,CNT
+4 SET CNT=0
+5 ;date cutoff for prescriptions
SET X2=-120
SET X1=DT
DO C^%DTC
SET PSODTCUT=X
+6 ;build psosd array
DO ^PSOBUILD
+7 SET STA=""
FOR
SET STA=$ORDER(PSOSD(STA))
if STA=""
QUIT
IF "^ACTIVE^NON-VERIFIED^REFILL^HOLD^DRUG INTERACTIONS^SUSPENDED^"[STA
Begin DoDot:1
+8 SET DRUG=""
FOR
SET DRUG=$ORDER(PSOSD(STA,DRUG))
if DRUG=""
QUIT
Begin DoDot:2
+9 SET RXIEN=+PSOSD(STA,DRUG)
+10 IF $$GET1^DIQ(52,RXIEN,100.2,"I")']""
QUIT
+11 SET CNT=CNT+1
End DoDot:2
End DoDot:1
+12 QUIT CNT
