11:09 AM  6-NOV-98
PCC HEALTH SUMMARY PATCH 2 (includes patches 1&2) Y2K
APCHS1
APCHS1 ; IHS/TUCSON/LAB - PART 1 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;  [ 11/04/98  8:11 PM ]
 ;;2.0;IHS RPMS/PCC Health Summary;**2**;JUN 24, 1997
 ;CMI/TUCSON/LAB - patch 2 fix age display
 ;
DEMOG ; ******************** DEMOGRAPHICS ********************
 ; <SETUP>
 S APCHSN=^DPT(APCHSPAT,0)
 S APCHSNAM=$P(APCHSN,U,1)
 S APCHSEX=$P(APCHSN,U,2),APCHSEX=$S(APCHSEX="M":"MALE",APCHSEX="F":"FEMALE",1:"<no sex>")
 S Y=$P(APCHSN,U,3)
 I 'Y S APCHSDOB="<NO DATE OF BIRTH>"
 E  X ^DD("DD") S APCHSDOB=Y
 S APCHSSN=$P(APCHSN,U,9) S:APCHSSN]"" APCHSSN=$E(APCHSSN,1,3)_"-"_$E(APCHSSN,4,5)_"-"_$E(APCHSSN,6,9)
 S APCHSN=$G(^DPT(APCHSPAT,.24))
 S APCHSMNM=$P(APCHSN,U,3)
 S APCHSFNM=$P(APCHSN,U)
 S APCHSN=^AUPNPAT(APCHSPAT,0)
 S Y=$P(APCHSN,U,3)
 I 'Y S APCHSLUD=""
 E  X ^DD("DD") S APCHSLUD=Y
 S APCHSBT=$P(APCHSN,U,13) S:APCHSBT="" APCHSBT="no blood type"
 ;S APCHSPP=$P(APCHSN,U,14) S:APCHSPP="" APCHSPP="<none identified>" I +APCHSPP S APCHSPP=$P(^DIC(6,+APCHSPP,0),U,1) I +APCHSPP S APCHSPP=$P(^DIC(16,+APCHSPP,0),U,1) ;*** file 200 conversion ***
 S APCHSPP=$P(APCHSN,U,14)
 S:APCHSPP="" APCHSPP="<none identified>"
 I +APCHSPP,$P(^DD(9000001,.14,0),U,2)[200 S APCHSPP=$P(^VA(200,APCHSPP,0),U) ;*** file 200 conversion ***
 I +APCHSPP S APCHSPP=$P(^DIC(6,+APCHSPP,0),U,1) I +APCHSPP S APCHSPP=$P(^DIC(16,+APCHSPP,0),U,1)
V ;
 S APCHSVST="" I $D(^DPT(APCHSPAT,"VET"))#2,$P(^("VET"),U)="Y" D VSTAT
 S APCHSN=$G(^AUPNPAT(APCHSPAT,11))
 S APCHSTR=$P(APCHSN,U,8)
 I 'APCHSTR S APCHSTR="<no tribe>"
 E  S APCHSTR=^AUTTTRI(APCHSTR,0) S APCHSTR=$P(APCHSTR,U,1)_$S($P(APCHSTR,U,4)="Y":" <old code>",1:"")
 S APCHSEL=$P(APCHSN,U,12)
 S X=$P(^DD(9000001,1112,0),U,3) F APCHSI=1:1 S APCHSP=$P(X,";",APCHSI) Q:APCHSP=""  I $P(APCHSP,":",1)=APCHSEL S APCHSEL=$P(APCHSP,":",2) Q
 S APCHSCMR=$P(APCHSN,U,18) S:APCHSCMR="" APCHSCMR="<NO COMMUNITY OF RESIDENCE>"
 S APCHSI=$O(^AUPNPAT(APCHSPAT,13,0)) S APCHSRE1=$S(APCHSI:^(APCHSI,0),1:"") S APCHSI=$O(^AUPNPAT(APCHSPAT,13,APCHSI)) S APCHSRE2=$S(APCHSI:^(APCHSI,0),1:"") S:$O(^AUPNPAT(APCHSPAT,13,APCHSI)) APCHSRE2=APCHSRE2_" [more]"
 S APCHSADR=""
 I $D(^DPT(APCHSPAT,.11)) S APCHSN=^(.11) F E=1:1:6 S APCHSP=$P(APCHSN,U,E) I APCHSP]"" S:E=5 APCHSP=$P(^DIC(5,APCHSP,0),U,2) S APCHSADR=APCHSADR_","_APCHSP
 S APCHSADR=$E(APCHSADR,2,255)
 S:APCHSADR]"" APCHSCMR=APCHSCMR_" ("_APCHSADR_")  "
 S APCHSN=$G(^DPT(APCHSPAT,.13))
 S APCHSHPH=$P(APCHSN,U,1),APCHSOPH=$P(APCHSN,U,2)
 I APCHSHPH="",APCHSOPH="" S APCHSHPH="<no phone numbers recorded>"
 S:+APCHSHPH APCHSHPH="(H) "_APCHSHPH
 S:APCHSOPH]"" APCHSOPH="(W) "_APCHSOPH S:APCHSHPH]"" APCHSOPH=" "_APCHSOPH
 G DEMDSP
VSTAT S APCHSVST="VETERAN"
 I $D(^DPT(APCHSPAT,.3))#2,$P(^(.3),U)="Y" S APCHSVST="SERVICE-CONNECTED "_APCHSVST
 S APCHSN=$G(^DPT(APCHSPAT,.32))
 I $P(APCHSN,U,5) S APCHSVST=APCHSVST_"  "_$P(^DIC(23,$P(APCHSN,U,5),0),U,2)
 S Y=$P(APCHSN,U,6) I Y D VSDT S APCHSVST=APCHSVST_" ("_Y_"-" S Y=$P(APCHSN,U,7) S:'Y APCHSVST=APCHSVST_"?)" I Y D VSDT S APCHSVST=APCHSVST_Y_")"
 I $D(^DPT(APCHSPAT,.31))#2 S APCHSN=^(.31) S Y=$P(APCHSN,U,3) I Y S APCHSVST=APCHSVST_"  CLAIM# "_Y
 Q
VSDT S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3))
 Q
DEMDSP ; <DISPLAY>
 X APCHSBRK
 I $$DOD^AUPNPAT(APCHSPAT)]"" W "*** DOD: ",$$FMTE^XLFDT($$DOD^AUPNPAT(APCHSPAT),"2D")," ***",!
 W APCHSNAM
 W:APCHSDOB]"" ?34,"DOB: ",APCHSDOB,?51,$$AGE(APCHSPAT,DT,"R")
 W:APCHSEX]"" ?59,APCHSEX
 W:APCHSBT]"" ?67,APCHSBT
 W !
 I APCHSTR]""!(APCHSMNM]"") W:APCHSTR]"" $E(APCHSTR,1,33) W:APCHSSN]"" ?34,"SSN: ",APCHSSN W !
 W:APCHSMNM]"" ?34,"MOTHER'S MAIDEN NAME: ",APCHSMNM W !
 W APCHSHPH,APCHSOPH W:APCHSFNM]"" ?34,"FATHER'S NAME: ",APCHSFNM W !
 I APCHSCMR]"" W APCHSCMR,!!
 I APCHSLUD]""!(APCHSEL]"") W:APCHSLUD]"" "LAST UPDATED: ",APCHSLUD,"   " W:APCHSEL]"" ?34,"ELIGIBILITY: ",APCHSEL W !
 W:APCHSVST]"" APCHSVST,!
 W !
 I $D(^AUPNPAT(APCHSPAT,41)) W "HEALTH RECORD NUMBERS:" F APCHSFP=0:0 S APCHSFP=$O(^AUPNPAT(APCHSPAT,41,APCHSFP)) Q:'APCHSFP  S APCHSHRN=$P(^(APCHSFP,0),U,2),APCHSFAC=$P(^DIC(4,APCHSFP,0),U,1) W ?24,$E(1000000+APCHSHRN,2,7),"  ",APCHSFAC,!
 W "DESIGNATED PROVIDER: ",APCHSPP,!
 I APCHSRE1]"" W "REMARKS:",?9,APCHSRE1,! W:APCHSRE2]"" ?9,APCHSRE2,!
 D DSPCMSRG
 ; <CLEANUP>
DEMOGX K APCHSNAM,APCHSTR,APCHSEX,APCHSDOB,APCHSSN,APCHSMNM,APCHSCMR,APCHSEL,APCHSFP,APCHSFAC,APCHSHRN,APCHSBT,APCHSPP,APCHSADR,APCHSN,APCHSP,APCHSI,APCHSJ,APCHSHPH,APCHSOPH,APCHSVST,APCHSLUD,APCHSRE1,APCHSRE2,E,X,Y
 Q
DSPCMSRG ; DISPLAY MEMBERSHIP IN CMS REGISTER
 D DSPCMSRG^APCHS
 Q
AGE(DFN,D,F) ;EP - Given DFN, return Age.
 I '$G(DFN) Q -1
 I '$D(^DPT(DFN,0)) Q -1
 I $$DOB^AUPNPAT(DFN,"")<0 Q -1
 S:$G(D)="" D=DT
 S:$G(F)="" F="Y"
 NEW %
 S %=$$FMDIFF^XLFDT(D,$$DOB^AUPNPAT(DFN,""))
 S %1=%\365.25
 I F="Y" Q %1
 ;beginning Y2K fix
 ;Q $S(%1>2:%1_" YRS",%<31:%1_" DYS",1:%\30_" MOS") ;Y2000
 Q $S(%1>2:%1_" YRS",%<31:%_" DYS",1:%\30_" MOS") ;Y2000
 ;end Y2K
 ;

APCHS2
APCHS2 ; IHS/TUCSON/LAB - PART 2 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;  [ 11/04/98  8:22 PM ]
 ;;2.0;IHS RPMS/PCC Health Summary;**2**;JUN 24, 1997
 ;CMI/TUCSON/LAB - patch 2 fixed AGE subroutine
 ;
MEAS ; ******************** MEASUREMENTS * 9000010.01 *******
 ; <SETUP>
 Q:'$D(^AUPNVMSR("AA",APCHSPAT))
 X APCHSBRK
 ; <DISPLAY>
 X APCHSCKP Q:$D(APCHSQIT)  W !
 S APCHSMT="" F APCHSQ=0:0 S APCHSMT=$O(^AUPNVMSR("AA",APCHSPAT,APCHSMT)) Q:APCHSMT=""  S APCHSND2=APCHSNDM D MEASDTYP Q:$D(APCHSQIT)
 ; <CLEANUP>
MEASX K APCHSMT,APCHSMT2,APCHSMT3,APCHSDFN,APCHSND2,APCHSDAT
 Q
MEASDTYP S APCHSMT2=$S($D(^AUTTMSR(APCHSMT,0)):$P(^(0),U,1),1:APCHSMT) S APCHSMT3=APCHSMT2
 S (APCHSIVD,APCHSDFN)="" F  S APCHSIVD=$O(^AUPNVMSR("AA",APCHSPAT,APCHSMT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  S APCHSND2=APCHSND2-1 Q:APCHSND2=-1  D MEASDSP
 I APCHSMT3="" X APCHSCKP Q:$D(APCHSQIT)  W !
 Q
MEASDSP S APCHSDFN=$O(^AUPNVMSR("AA",APCHSPAT,APCHSMT,APCHSIVD,"")),Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y X APCHSCKP Q:$D(APCHSQIT)  W:APCHSNPG!(APCHSMT3]"") APCHSMT2 S APCHSMT3="" W ?5,APCHSDAT,?18,$P(^AUPNVMSR(APCHSDFN,0),U,4),!
 Q
 ;
IMMUN ; ******************** IMMUNIZATIONS * 9000010.11 *******
 ; <SETUP>
 Q:'$D(^AUPNVIMM("AA",APCHSPAT))
 X APCHSCKP Q:$D(APCHSQIT)  X:'APCHSNPG APCHSBRK
 ; <DISPLAY>
 S APCHSITP="" F APCHSQ=0:0 S APCHSITP=$O(^AUPNVIMM("AA",APCHSPAT,APCHSITP)) Q:APCHSITP=""  D IMMDTYP
 ; <CLEANUP>
IMMUNX K APCHSITP,APCHSITX,APCHSITL,APCHSDFN,APCHSDAT,APCHSIVD,APCHSVDF
 K APCHSIMC,APCHSIMR,APCHSN,APCHSIC,APCHSIR
 K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE
 Q
IMMDTYP S APCHSITX=$P(^AUTTIMM(APCHSITP,0),U,2),APCHSITL=$L(APCHSITX) X APCHSCKP Q:$D(APCHSQIT)  W ! X APCHSCKP Q:$D(APCHSQIT)  W APCHSITX S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVIMM("AA",APCHSPAT,APCHSITP,APCHSIVD)) Q:'APCHSIVD  D IMMDSP
 Q
IMMDSP S APCHSDFN=0 F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVIMM("AA",APCHSPAT,APCHSITP,APCHSIVD,APCHSDFN)) Q:APCHSDFN=""  D IMMDSP2
 Q
IMMDSP2 S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
 S APCHSN=^AUPNVIMM(APCHSDFN,0)
 S APCHSVDF=$P(APCHSN,U,3) D GETSITEV^APCHSUTL S APCHSITE=APCHSNSH
 S X=$P(APCHSN,U,6),Y=.06 D IMMGSET S APCHSIR=APCHSP
 S X=$P(APCHSN,U,7),Y=.07 D IMMGSET S APCHSIC=APCHSP S:APCHSIC]"" APCHSIC="DO NOT REPEAT"
 I APCHSIC]"",APCHSIR]"" S APCHSIR=APCHSIR_"; "
 S APCHSIR=APCHSIR_APCHSIC
 ;modified following line - LAB
 X APCHSCKP Q:$D(APCHSQIT)  W:APCHSNPG APCHSITX W ?(APCHSITL+1),$P(^AUPNVIMM(APCHSDFN,0),U,4),?15,APCHSDAT,?25,$$AGE(APCHSPAT,$P(+^AUPNVSIT(APCHSVDF,0),"."),"P"),?34,APCHSITE,?65,APCHSIR,!
 Q
IMMGSET S Y=$G(^DD(9000010.11,Y,0)),Y=$P(Y,U,3)
 S:'X Y=""
 F APCHSQ=1:1 S APCHSP=$P(Y,";",APCHSQ) Q:APCHSP=""  I $P(APCHSP,":",1)=X S APCHSP=$P(APCHSP,":",2) Q
 Q
 ;
 ;-----------
AGE(DFN,D,F) ;(DFN) Given DFN, return Age. ; AUPN*93.2*3
 I '$G(DFN) Q -1
 I '$D(^DPT(DFN,0)) Q -1
 I $$DOB^AUPNPAT(DFN)<0 Q -1
 S:$G(D)="" D=DT
 S:$G(F)="" F="Y"
 NEW %
 S %=$$FMDIFF^XLFDT(D,$$DOB^AUPNPAT(DFN))
 I F="Y" Q %\365.25
 ;beginning Y2K
 ;NEW %1 S %1=%\365.25,%=$S(%1>2:%1_" YRS",%<31:%1_" DYS",1:%\30_" MOS") ;Y2000
 NEW %1 S %1=%\365.25,%=$S(%1>2:%1_" YRS",%<31:%_" DYS",1:%\30_" MOS") ;Y2000
 ;end Y2000
 Q %
 ;
 ;-----------

APCHS7
APCHS7 ; IHS/TUCSON/LAB - PART 7 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;  [ 06/24/97  2:42 PM ]
 ;;2.0;IHS RPMS/PCC HEALTH SUMMARY;**1**;JUN 24, 1997
 ;
 ;
MEDSCURR ; ************** CURRENT MEDICATIONS * 9000010.14 ********
 S APCHSMTY="CURR" G CONT
MEDSALL ; **************** ALL MEDICATIONS * 9000010.14 **********
 S APCHSMTY="ALL" G CONT
MEDSCHRN ; ************* CHRONIC MEDCICATIONS ************
 S APCHSMTY="CHRONIC" G CONT
MEDSNDUP ; ************* ALL, NON DUPLICATED *************
 S APCHSMTY="NODUP" G CONT
 ;
CONT ; <SETUP>
 Q:'$D(^AUPNVMED("AC",APCHSPAT))
 X APCHSCKP Q:$D(APCHSQIT)  I 'APCHSNPG W ! X APCHSBRK
 ; <BUILD>
 K ^TMP($J,"APCHSMTB"),^TMP($J,"APCHSMTP")
 S APCHSIVD=0 F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVMED("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)  S APCHSMX=0 F APCHSQ=0:0 S APCHSMX=$O(^AUPNVMED("AA",APCHSPAT,APCHSIVD,APCHSMX)) Q:APCHSMX=""  D MEDBLD
 ; <DISPLAY>
 S APCHSIVD=0 F APCHSQ=0:0 S APCHSIVD=$O(^TMP($J,"APCHSMTP",APCHSIVD)) Q:'APCHSIVD  D MEDDSP
 ; <CLEANUP>
MEDX K APCHSIVD,APCHSMX,APCHSMFX,APCHSQTY,APCHSIG,APCHSSGY,APCHSEXP,APCHSMTS,APCHSMED,APCHSDTM,APCHSDAT,APCHSDYS,APCHSN,APCHSDC,APCHSVDF,APCHSP
 K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE,APCHSRX,APCHSDRG,APCHSCRN,APCHSREF,APCHSRFL,APCHSALL,APCHSTXT,APCHSMTY
 K ^TMP($J,"APCHSMTB"),^TMP($J,"APCHSMTP")
 K X1,X2,X,Y
 Q
MEDBLD ;BUILD ARRAY OF MEDICATIONS 
 ;APCHSDC=DATE DISCONTINUED,DYS=DAYS PRESCRIBED,SIG=DIRECTIONS
 ;VDF=VISIT FILE DATE
 S APCHSN=^AUPNVMED(APCHSMX,0)
 Q:'$D(^PSDRUG($P(APCHSN,U,1)))
 S APCHSDTM=-APCHSIVD\1+9999999
 ;S APCHSDC=$P(APCHSN,U,8),APCHSDYS=$P(APCHSN,U,7),APCHSMFX=+APCHSN
 S APCHSDC=$P(APCHSN,U,8),APCHSDYS=$P(APCHSN,U,7),APCHSMFX=$S($P(APCHSN,U,4)="":+APCHSN,1:$P(APCHSN,U,4))
 ;I $D(^TMP($J,"APCHSMTB",APCHSMFX)),^TMP($J,"APCHSMTB",APCHSMFX)="" Q
 S:APCHSDYS="" APCHSDYS=30
 ;SCREENS OUT MEDS NOT CURRENT; APCHSALL FORCES INCLUSION OF ALL MEDS
 ;I 'APCHSALL S X1=DT,X2=APCHSDTM D ^%DTC Q:X>60&(X>(2*APCHSDYS))
 ;S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
 D @APCHSMTY
 Q
 ;
CURR ; current meds only
 I $D(^TMP($J,"APCHSMTB",APCHSMFX)),^TMP($J,"APCHSMTB",APCHSMFX)="" Q
 S X1=DT,X2=APCHSDTM D ^%DTC Q:X>60&(X>(2*APCHSDYS))
 S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
 Q
ALL ;all meds included
 S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
 ;
 Q
NODUP ;
 I $D(^TMP($J,"APCHSMTB",APCHSMFX)) Q
 S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
 Q
CHRONIC ;chronic meds only
 I $D(^TMP($J,"APCHSMTB",APCHSMFX)) Q
 S X=$S($D(^PSRX("APCC",APCHSMX)):$O(^(APCHSMX,0)),1:0)
 S Y=$S(+X:$D(^PS(55,APCHSPAT,"P","CP",X)),1:0)
 Q:'Y
 S ^TMP($J,"APCHSMTB",APCHSMFX)=APCHSDC,^TMP($J,"APCHSMTP",APCHSIVD_"-"_APCHSMFX)=APCHSMX
 Q
MEDDSP ;DISPLAY MEDICATION
 ;APCHSRX=RX# in FILE 52,CHRN=CHRONIC FLAG,REF=#REFILLS
 S APCHSMX=^TMP($J,"APCHSMTP",APCHSIVD)
 S APCHSN=^AUPNVMED(APCHSMX,0)
 S APCHSRX=$S($D(^PSRX("APCC",APCHSMX)):$O(^(APCHSMX,0)),1:0)
 S APCHSCRN=$S(+APCHSRX:$D(^PS(55,APCHSPAT,"P","CP",APCHSRX)),1:0)
 S (Y,APCHSDTM)=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
 S APCHSDC=$P(APCHSN,U,8),APCHSDYS=$P(APCHSN,U,7),APCHSQTY=$P(APCHSN,U,6),APCHSIG=$P(APCHSN,U,5),APCHSVDF=$P(APCHSN,U,3),APCHSMFX=+APCHSN
 S:APCHSDYS="" APCHSDYS=30
 S X1=DT,X2=APCHSDTM D ^%DTC ;Q:X>60&(X>(2*APCHSDYS))
 S APCHSEXP=""
 I X>APCHSDYS S X1=APCHSDTM,X2=APCHSDYS D C^%DTC S Y=X X APCHSCVD S APCHSEXP="-- Ran out "_Y
 S APCHSMED=$S($P(APCHSN,U,4)="":$P(^PSDRUG(APCHSMFX,0),U,1),1:$P(APCHSN,U,4))
 I APCHSDC S Y=APCHSDC X APCHSCVD S APCHSEXP="-- D/C "_Y
 D SIG S APCHSIG=APCHSSGY
 D REF I APCHSREF S APCHSIG=APCHSIG_" "_APCHSREF_$S(APCHSREF=1:" refill",1:" refills")_" left."
 D SITE I APCHSITE]"" S APCHSIG=APCHSIG_"  ["_APCHSITE_"]"
 X APCHSCKP Q:$D(APCHSQIT)
 W APCHSDAT,?10,$S(APCHSCRN:"(C)",1:""),?14,APCHSMED," #",APCHSQTY," (",APCHSDYS," days) ",APCHSEXP,!
 X APCHSCKP Q:$D(APCHSQIT)
 S APCHSICL=14,APCHSNRQ="",APCHSTXT=APCHSIG D PRTTXT^APCHSUTL K APCHSICL,APCHSNRQ,APCHSP
 Q
 ;
SIG ;CONSTRUCT THE FULL TEXT FROM THE ENCODED SIG
 I $$VALI^XBDIQ1(9001015,APCHSTYP,3.5)="S" S APCHSSGY=APCHSIG Q
 S APCHSSGY="" F APCHSP=1:1:$L(APCHSIG," ") S X=$P(APCHSIG," ",APCHSP) I X]"" D
 . S Y=$O(^PS(51,"B",X,0)) I Y>0 S X=$P(^PS(51,Y,0),"^",2) I $D(^(9)) S Y=$P(APCHSIG," ",APCHSP-1),Y=$E(Y,$L(Y)) S:Y>1 X=$P(^(9),"^",1)
 . S APCHSSGY=APCHSSGY_X_" "
 Q
 ;
REF ;DETERMINE THE NUMBER OF REFILLS REMAINING
 I 'APCHSRX S APCHSREF=0 Q
 S APCHSRFL=$P(^PSRX(APCHSRX,0),U,9) S APCHSREF=0 F  S APCHSREF=$O(^PSRX(APCHSRX,1,APCHSREF)) Q:'APCHSREF  S APCHSRFL=APCHSRFL-1
 S APCHSREF=APCHSRFL
 Q
 ;
SITE ;DETERMINE IF OUTSIDE LOCATION INFO PRESENT
 S APCHSITE=""
 I $D(^AUPNVSIT(APCHSVDF,21))#2 S APCHSITE=$P(^(21),U)
 Q