APCHSM06 ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;
;;2.0;IHS PCC SUITE;**2,11,14,16**;MAY 14, 2009;Build 9
;IHS/CMI/LAB - uncommented age limit on pap smear
;
; ******************** SURVEILLANCE - HARD CODE ********************
S(X) ;
NEW %,C S (C,%)=0 F S %=$O(APCHSTEX(%)) Q:%'=+% S C=C+1
S APCHSTEX(C+1)=X
Q
PPDWT ;
S V=$$REF^APCHSMU(APCHSPAT,9999999.28,APCHSFLX,APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
D WRITE^APCHSMU
X APCHSURX
Q
PPD ;EP - PPD
X APCHSURX
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
S APCHSFLX=$O(^AUTTSK("B","PPD",0)),APCHIMMC="PPD"
S APCHICAR=$$LASTITEM^APCLAPIU(APCHSPAT,"PPD","SKIN",,,"A")
S APCHLAST=$P(APCHICAR,U,1)
S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
I $P(APCHOVR,U)>APCHLAST D Q
.S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)
.D PPDWT
.Q
PPDREG ;
I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
I 'APCHSCRI D PPDIHS Q
I APCHSINT="" X APCHSURX Q ;no frequency so skip it
I $$PPDS^APCHS9B5(APCHSPAT)]"" X APCHSURX Q ;known tb
I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D PPDWT Q
S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
D PPDWT
Q
;
PPDIHS ;
Q:APCHSAGE>18
Q:APCHSAGE<4
S APCHMIN=4
I $$PPDS^APCHS9B5(APCHSPAT)]"" X APCHSURX Q ;known tb
I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D PPDWT Q
S APCHSOLD=$$FMDIFF^XLFDT(APCHLAST,APCHSDOB)
I APCHSAGE>3,APCHSAGE<11 D Q
.I APCHSOLD<(3*365) S APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(4*365))) D PPDWT Q
.S APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(11*365)),APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D PPDWT Q
I APCHSAGE>10,APCHSOLD<(9*365) S APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(11*365))) D PPDWT Q
Q
;
LDL1 ;
X APCHSURX
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S X=$$PLTAX^APCHSMU(APCHSPAT,"BGP IHD DXS") ;is ihd on problem list
S Y=$$LASTITEM^APCLAPIU(APCHSPAT,"[BGP IHD DXS]","DX")
I Y]"",Y<$$FMADD^XLFDT(DT,-365) S Y=""
I 'X,'Y Q ;no pl dx and no pov in past year
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
I 'APCHSCRI D
.Q:APCHSAGE<18
.S APCHSINT=365
.S APCHMIN=18
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHTAXN=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
I APCHSINT,APCHTAXN="" S APCHSTEX(1)="DM AUDIT LDL CHOLESTEROL TAX Taxonomy Missing" D WRITE^APCHSMU X APCHSURX Q
S APCHICAR=$$LASTLAB^APCLAPIU(APCHSPAT,,,,$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0)),,$O(^ATXAX("B","BGP LDL LOINC CODES",0)),"A")
S APCHLAST=$P(APCHICAR,U,1)
S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
I $P(APCHOVR,U)>APCHLAST D Q
.S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)
.D REF^APCHSM02
.D WRITE^APCHSMU
.X APCHSURX
.Q
LDL1REG ;regular stuff
I APCHSINT="" X APCHSURX Q ;no frequency so skip it
I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D Q
.D REF^APCHSM02
.D WRITE^APCHSMU
.X APCHSURX
.Q
S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
D REF^APCHSM02
D WRITE^APCHSMU
X APCHSURX
Q
;
LDL2 ;
X APCHSURX
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S X=$$PLTAX^APCHSMU(APCHSPAT,"BGP IHD DXS") ;is ihd on problem list
S Y=$$LASTITEM^APCHSMU(APCHSPAT,"[BGP IHD DXS]","DX")
I Y]"",Y<$$FMADD^XLFDT(DT,-365) S Y=""
I 'X,'Y Q ;no pl dx and no pov in past year
;S APCHICAR=$$LASTLDL(APCHSPAT) ;IF Last one in 5 years NOT >=100 THEN QUIT
;S APCHLAST=$P(APCHICAR,U,1)
S APCHICAR=$$LASTLAB^APCLAPIU(APCHSPAT,$$FMADD^XLFDT(DT,-(5*365)),DT,,$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0)),,$O(^ATXAX("B","BGP LDL LOINC CODES",0)),"A")
S APCHLAST=$P(APCHICAR,U,1)
I 'APCHLAST Q ;last ldl in past 5 years not >=100
S APCHRES=$P(APCHICAR,U,3)
I APCHRES'=+APCHRES Q ;not a valid ldl value
I APCHRES'>100 Q ;not greater than 100
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
I 'APCHSCRI D
.Q:APCHSAGE<18
.S APCHSINT=365
.S APCHMIN=18
S APCHNEXT="" K APCHSTEX
S APCHTAXN=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
I APCHSINT,APCHTAXN="" S APCHSTEX(1)="DM AUDIT LDL CHOLESTEROL TAX Taxonomy Missing" D WRITE^APCHSMU X APCHSURX Q
S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
I $P(APCHOVR,U)>APCHLAST D Q
.S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)
.D REF^APCHSM02
.D WRITE^APCHSMU
.X APCHSURX
.Q
LDL2REG ;regular stuff
S APCHSTEX(1)="Last LDL above goal "_$$FMTE^XLFDT($P(APCHLAST,U))_" "_APCHRES D Q
.D REF^APCHSM02
.D WRITE^APCHSMU
.X APCHSURX
.Q
Q
;
SETR ;
Q:$P(V,U,3)<APCHLAST
Q:APCHLSTR>$P(V,U,3)
S APCHLSTR=$P(V,U,3)
S APCHLSTR(1)=$P(V,U,1)
S APCHLSTR(2)=$P(V,U,2)
Q
OSTEOREF ;
S X="" K APCHLSTR S APCHLSTR=""
I X="" S V=$$REF^APCHSMU(APCHSPAT,81,$O(^ICD0("BA",88.98,0)),APCHLAST) I V]"" D SETR
S APCHT=$O(^ATXAX("B","BGP OSTEO SCREEN CPTS",0))
I APCHT S V=$$RADREF^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT) I V]"" D SETR
S APCHT=$O(^ATXAX("B","BGP OSTEO SCREEN CPTS",0))
I APCHT S V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT) I V]"" D SETR
I APCHLSTR]"" S X=$G(APCHLSTR(1)) D S(X) S X=$G(APCHLSTR(2)) I X]"" D S(X)
Q
;
OSTOWT ;
K APCHV
D OSTEOREF
D WRITE^APCHSMU
X APCHSURX
Q
OSTEO ;EP - OSTEOPOROSIS screening
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHHOST=""
I $$LASTDX^APCHSMU2(APCHSPAT,"BGP OSTEOPOROSIS DXS",$P(^DPT(DFN,0),U,3),DT) S APCHHOST=1 ;had osteoporosis dx
I 'APCHHOST,$$PLTAX^APCHSMU(APCHSPAT,"BGP OSTEOPOROSIS DXS",,1) S APCHHOST=1 ;OSTEO is on Problem List
I 'APCHHOST,$$IPLSNO^APCHSMU1(APCHSPAT,"PXRM OSTEOPOROSIS-OSTEOPENIA",1) S APCHHOST=1
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHICAR=$$LASTOST^APCLAPI4(APCHSPAT,,,"A")
S APCHLAST=$P(APCHICAR,U,1)
S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
I $P(APCHOVR,U)>APCHLAST D Q
.S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)
.D OSTEOREF
.D WRITE^APCHSMU
.X APCHSURX
.Q
OSTOREG ;regular stuff
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I 'APCHSCRI,APCHSAGE>64,$P(^DPT(APCHSPAT,0),U,2)="F" S APCHSINT=(365*2),APCHMIN=65
I 'APCHSCRI Q:$P(^DPT(APCHSPAT,0),U,2)'="F"
I 'APCHSCRI Q:APCHSAGE<65
I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT) ;return in APCHSINT the frequency in days for this age/sex
I APCHSINT="" X APCHSURX Q ;no frequency so skip it
I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D OSTOWT Q
S A=$$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)
I 'APCHHOST D Q
.I APCHLAST'<A Q ;HAD ONE AFTER AGE 65
.S APCHNEXT=A
.I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
.I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
.D OSTOWT
I APCHHOST D Q
.;every 2 years
.S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
.I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
.I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
.D OSTOWT
Q
;
AOFOWT ;
K APCHV
D WRITE^APCHSMU
X APCHSURX
Q
AOF ;EP - AOF
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHICAR=$$LASTAOF^APCLAPI4(APCHSPAT,,,"A")
S APCHLAST=$P(APCHICAR,U,1)
S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
I $P(APCHOVR,U)>APCHLAST D Q
.S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)
.D WRITE^APCHSMU
.X APCHSURX
.Q
AOFOREG ;regular stuff
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I 'APCHSCRI,APCHSAGE>64 S APCHSINT=365,APCHMIN=65
I 'APCHSCRI Q:APCHSAGE<65
I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT),APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT) ;return in APCHSINT the frequency in days for this age/sex
I APCHSINT="" X APCHSURX Q ;no frequency so skip it
I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D AOFOWT Q
S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
D AOFOWT
Q
CHLEOREF ;
S X="" K APCHLSTR S APCHLSTR=""
S APCHT=$O(^ATXAX("B","BGP CHLAMYDIA CPTS",0))
I APCHT S V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT) I V]"" D SETR
I APCHLSTR]"" S X=$G(APCHLSTR(1)) D S(X) S X=$G(APCHLSTR(2)) I X]"" D S(X)
S APCHTAXN=$O(^ATXLAB("B","BGP CHLAMYDIA TESTS TAX",0)) D REF^APCHSM02
Q
;
CHLOWT ;
K APCHV
D CHLEOREF
D WRITE^APCHSMU
X APCHSURX
Q
CHLEO ;EP - CHLAMYDIA screening
Q:$P(^DPT(APCHSPAT,0),U,2)'="F" ;females only
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
NEW D,APCH16BD,APCH25BD,APCH26BD
S D=$P(^DPT(DFN,0),U,3)
S APCH16BD=$E(D,1,3)+16_$E(D,4,7)
S APCH26BD=$E(D,1,3)+26_$E(D,4,7),APCH25BD=$$FMADD^XLFDT(APCH26BD,-1)
I $$LASTDX^APCHSMU2(APCHSPAT,"BKM CHLAMYDIA DXS",$$FMADD^XLFDT(DT,-365),DT) Q ;had CHLAMYDIA dx in past year so don't prompt
;I $$PLTAX^APCHSMU(APCHSPAT,"BKM CHLAMYDIA DXS") Q ;chlamydia on problem list -NO per Susan
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHICAR=$$LASTCHLA^APCLAPI5(APCHSPAT,,DT,"A")
S APCHLAST=$P(APCHICAR,U,1)
S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
I $P(APCHOVR,U)>APCHLAST D Q
.S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)
.D CHLEOREF
.D WRITE^APCHSMU
.X APCHSURX
.Q
CHLOREG ;regular stuff
;S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
Q:APCHSAGE>25
Q:APCHSAGE<16
;I $$LASTCHLA^APCLAPI5(APCHSPAT,,DT)]"" Q
S APCHSINT=365
;I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT) ;return in APCHSINT the frequency in days for this age/sex
I APCHSINT="" X APCHSURX Q ;no frequency so skip it
I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU(APCH16BD) D CHLOWT Q
S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
D CHLOWT
Q
;
HIVEOREF ;
S X="" K APCHLSTR S APCHLSTR=""
S APCHT=$O(^ATXAX("B","BGP CPT HIV TESTS",0))
I APCHT S V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT) I V]"" D SETR
I APCHLSTR]"" S X=$G(APCHLSTR(1)) D S(X) S X=$G(APCHLSTR(2)) I X]"" D S(X)
S APCHTAXN=$O(^ATXLAB("B","BGP HIV TEST TAX",0)) D REF^APCHSM02
Q
;
HIVOWT ;
K APCHV
D HIVEOREF
D WRITE^APCHSMU
X APCHSURX
Q
HIVSCR ;EP - HIV screening
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
I $$LASTDX^APCHSMU2(APCHSPAT,"BGP HIV/AIDS DXS",$P(^DPT(DFN,0),U,3),DT) Q ;had HIV dx
I $$PLTAX^APCHSMU(APCHSPAT,"BGP HIV/AIDS DXS",,1) X APCHSURX Q ;HIV on problem list
I $$IPLSNO^APCHSMU1(APCHSPAT,"PXRM HIV",1) X APCHSURX Q
NEW D,APCH13BD,APCH65BD,APCH64BD
S D=$P(^DPT(DFN,0),U,3)
S APCH13BD=$E(D,1,3)+13_$E(D,4,7)
S APCH65BD=$E(D,1,3)+65_$E(D,4,7),APCH64BD=$$FMADD^XLFDT(APCH65BD,-1)
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHICAR=$$LASTHIVS^APCLAPI5(APCHSPAT,APCH13BD,APCH64BD,"A")
S APCHLAST=$P(APCHICAR,U,1)
S APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
I $P(APCHOVR,U)>APCHLAST D Q
.S X=$$DATE^APCHSMU($P(APCHOVR,U))_" (per "_$P(APCHOVR,U,2)_")" D S(X) S X=$P(APCHOVR,U,3) D S(X)
.D HIVEOREF
.D WRITE^APCHSMU
.X APCHSURX
.Q
HIVOREG ;regular stuff
S APCHSINT=1 ;,APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
Q:APCHSAGE>64
Q:APCHSAGE<13
I APCHLAST]"" Q
S APCHSINT=1
;I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT) ;return in APCHSINT the frequency in days for this age/sex
I APCHSINT="" X APCHSURX Q ;no frequency so skip it
I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU(APCH13BD) D HIVOWT Q
S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
D HIVOWT
Q
;
APCHSM06 ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;
+1 ;;2.0;IHS PCC SUITE;**2,11,14,16**;MAY 14, 2009;Build 9
+2 ;IHS/CMI/LAB - uncommented age limit on pap smear
+3 ;
+4 ; ******************** SURVEILLANCE - HARD CODE ********************
S(X) ;
+1 NEW %,C
SET (C,%)=0
FOR
SET %=$ORDER(APCHSTEX(%))
IF %'=+%
QUIT
SET C=C+1
+2 SET APCHSTEX(C+1)=X
+3 QUIT
PPDWT ;
+1 SET V=$$REF^APCHSMU(APCHSPAT,9999999.28,APCHSFLX,APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+2 DO WRITE^APCHSMU
+3 XECUTE APCHSURX
+4 QUIT
PPD ;EP - PPD
+1 XECUTE APCHSURX
+2 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+3 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+4 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+5 SET APCHSFLX=$ORDER(^AUTTSK("B","PPD",0))
SET APCHIMMC="PPD"
+6 SET APCHICAR=$$LASTITEM^APCLAPIU(APCHSPAT,"PPD","SKIN",,,"A")
+7 SET APCHLAST=$PIECE(APCHICAR,U,1)
+8 SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
+9 IF $PIECE(APCHOVR,U)>APCHLAST
Begin DoDot:1
+10 SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+11 DO PPDWT
+12 QUIT
End DoDot:1
QUIT
PPDREG ;
+1 IF APCHSCRI
SET APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT)
SET APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
+2 IF 'APCHSCRI
DO PPDIHS
QUIT
+3 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+4 ;known tb
IF $$PPDS^APCHS9B5(APCHSPAT)]""
XECUTE APCHSURX
QUIT
+5 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
DO PPDWT
QUIT
+6 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+7 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+8 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+9 DO PPDWT
+10 QUIT
+11 ;
PPDIHS ;
+1 IF APCHSAGE>18
QUIT
+2 IF APCHSAGE<4
QUIT
+3 SET APCHMIN=4
+4 ;known tb
IF $$PPDS^APCHS9B5(APCHSPAT)]""
XECUTE APCHSURX
QUIT
+5 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
DO PPDWT
QUIT
+6 SET APCHSOLD=$$FMDIFF^XLFDT(APCHLAST,APCHSDOB)
+7 IF APCHSAGE>3
IF APCHSAGE<11
Begin DoDot:1
+8 IF APCHSOLD<(3*365)
SET APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(4*365)))
DO PPDWT
QUIT
+9 SET APCHNEXT=$$FMADD^XLFDT(APCHSDOB,(11*365))
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
DO PPDWT
QUIT
End DoDot:1
QUIT
+10 IF APCHSAGE>10
IF APCHSOLD<(9*365)
SET APCHSTEX(1)=$$DATE^APCHSMU($$FMADD^XLFDT(APCHSDOB,(11*365)))
DO PPDWT
QUIT
+11 QUIT
+12 ;
LDL1 ;
+1 XECUTE APCHSURX
+2 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+3 ;is ihd on problem list
SET X=$$PLTAX^APCHSMU(APCHSPAT,"BGP IHD DXS")
+4 SET Y=$$LASTITEM^APCLAPIU(APCHSPAT,"[BGP IHD DXS]","DX")
+5 IF Y]""
IF Y<$$FMADD^XLFDT(DT,-365)
SET Y=""
+6 ;no pl dx and no pov in past year
IF 'X
IF 'Y
QUIT
+7 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+8 IF APCHSCRI
SET APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT)
SET APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
+9 IF 'APCHSCRI
Begin DoDot:1
+10 IF APCHSAGE<18
QUIT
+11 SET APCHSINT=365
+12 SET APCHMIN=18
End DoDot:1
+13 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+14 SET APCHTAXN=$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
+15 IF APCHSINT
IF APCHTAXN=""
SET APCHSTEX(1)="DM AUDIT LDL CHOLESTEROL TAX Taxonomy Missing"
DO WRITE^APCHSMU
XECUTE APCHSURX
QUIT
+16 SET APCHICAR=$$LASTLAB^APCLAPIU(APCHSPAT,,,,$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0)),,$ORDER(^ATXAX("B","BGP LDL LOINC CODES",0)),"A")
+17 SET APCHLAST=$PIECE(APCHICAR,U,1)
+18 SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
+19 IF $PIECE(APCHOVR,U)>APCHLAST
Begin DoDot:1
+20 SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+21 DO REF^APCHSM02
+22 DO WRITE^APCHSMU
+23 XECUTE APCHSURX
+24 QUIT
End DoDot:1
QUIT
LDL1REG ;regular stuff
+1 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+2 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
Begin DoDot:1
+3 DO REF^APCHSM02
+4 DO WRITE^APCHSMU
+5 XECUTE APCHSURX
+6 QUIT
End DoDot:1
QUIT
+7 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+8 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+9 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+10 DO REF^APCHSM02
+11 DO WRITE^APCHSMU
+12 XECUTE APCHSURX
+13 QUIT
+14 ;
LDL2 ;
+1 XECUTE APCHSURX
+2 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+3 ;is ihd on problem list
SET X=$$PLTAX^APCHSMU(APCHSPAT,"BGP IHD DXS")
+4 SET Y=$$LASTITEM^APCHSMU(APCHSPAT,"[BGP IHD DXS]","DX")
+5 IF Y]""
IF Y<$$FMADD^XLFDT(DT,-365)
SET Y=""
+6 ;no pl dx and no pov in past year
IF 'X
IF 'Y
QUIT
+7 ;S APCHICAR=$$LASTLDL(APCHSPAT) ;IF Last one in 5 years NOT >=100 THEN QUIT
+8 ;S APCHLAST=$P(APCHICAR,U,1)
+9 SET APCHICAR=$$LASTLAB^APCLAPIU(APCHSPAT,$$FMADD^XLFDT(DT,-(5*365)),DT,,$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0)),,$ORDER(^ATXAX("B","BGP LDL LOINC CODES",0)),"A")
+10 SET APCHLAST=$PIECE(APCHICAR,U,1)
+11 ;last ldl in past 5 years not >=100
IF 'APCHLAST
QUIT
+12 SET APCHRES=$PIECE(APCHICAR,U,3)
+13 ;not a valid ldl value
IF APCHRES'=+APCHRES
QUIT
+14 ;not greater than 100
IF APCHRES'>100
QUIT
+15 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+16 IF APCHSCRI
SET APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT)
SET APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
+17 IF 'APCHSCRI
Begin DoDot:1
+18 IF APCHSAGE<18
QUIT
+19 SET APCHSINT=365
+20 SET APCHMIN=18
End DoDot:1
+21 SET APCHNEXT=""
KILL APCHSTEX
+22 SET APCHTAXN=$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
+23 IF APCHSINT
IF APCHTAXN=""
SET APCHSTEX(1)="DM AUDIT LDL CHOLESTEROL TAX Taxonomy Missing"
DO WRITE^APCHSMU
XECUTE APCHSURX
QUIT
+24 SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
+25 IF $PIECE(APCHOVR,U)>APCHLAST
Begin DoDot:1
+26 SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+27 DO REF^APCHSM02
+28 DO WRITE^APCHSMU
+29 XECUTE APCHSURX
+30 QUIT
End DoDot:1
QUIT
LDL2REG ;regular stuff
+1 SET APCHSTEX(1)="Last LDL above goal "_$$FMTE^XLFDT($PIECE(APCHLAST,U))_" "_APCHRES
Begin DoDot:1
+2 DO REF^APCHSM02
+3 DO WRITE^APCHSMU
+4 XECUTE APCHSURX
+5 QUIT
End DoDot:1
QUIT
+6 QUIT
+7 ;
SETR ;
+1 IF $PIECE(V,U,3)<APCHLAST
QUIT
+2 IF APCHLSTR>$PIECE(V,U,3)
QUIT
+3 SET APCHLSTR=$PIECE(V,U,3)
+4 SET APCHLSTR(1)=$PIECE(V,U,1)
+5 SET APCHLSTR(2)=$PIECE(V,U,2)
+6 QUIT
OSTEOREF ;
+1 SET X=""
KILL APCHLSTR
SET APCHLSTR=""
+2 IF X=""
SET V=$$REF^APCHSMU(APCHSPAT,81,$ORDER(^ICD0("BA",88.98,0)),APCHLAST)
IF V]""
DO SETR
+3 SET APCHT=$ORDER(^ATXAX("B","BGP OSTEO SCREEN CPTS",0))
+4 IF APCHT
SET V=$$RADREF^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT)
IF V]""
DO SETR
+5 SET APCHT=$ORDER(^ATXAX("B","BGP OSTEO SCREEN CPTS",0))
+6 IF APCHT
SET V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT)
IF V]""
DO SETR
+7 IF APCHLSTR]""
SET X=$GET(APCHLSTR(1))
DO S(X)
SET X=$GET(APCHLSTR(2))
IF X]""
DO S(X)
+8 QUIT
+9 ;
OSTOWT ;
+1 KILL APCHV
+2 DO OSTEOREF
+3 DO WRITE^APCHSMU
+4 XECUTE APCHSURX
+5 QUIT
OSTEO ;EP - OSTEOPOROSIS screening
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 SET APCHHOST=""
+3 ;had osteoporosis dx
IF $$LASTDX^APCHSMU2(APCHSPAT,"BGP OSTEOPOROSIS DXS",$PIECE(^DPT(DFN,0),U,3),DT)
SET APCHHOST=1
+4 ;OSTEO is on Problem List
IF 'APCHHOST
IF $$PLTAX^APCHSMU(APCHSPAT,"BGP OSTEOPOROSIS DXS",,1)
SET APCHHOST=1
+5 IF 'APCHHOST
IF $$IPLSNO^APCHSMU1(APCHSPAT,"PXRM OSTEOPOROSIS-OSTEOPENIA",1)
SET APCHHOST=1
+6 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+7 SET APCHICAR=$$LASTOST^APCLAPI4(APCHSPAT,,,"A")
+8 SET APCHLAST=$PIECE(APCHICAR,U,1)
+9 SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
+10 IF $PIECE(APCHOVR,U)>APCHLAST
Begin DoDot:1
+11 SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+12 DO OSTEOREF
+13 DO WRITE^APCHSMU
+14 XECUTE APCHSURX
+15 QUIT
End DoDot:1
QUIT
OSTOREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF 'APCHSCRI
IF APCHSAGE>64
IF $PIECE(^DPT(APCHSPAT,0),U,2)="F"
SET APCHSINT=(365*2)
SET APCHMIN=65
+3 IF 'APCHSCRI
IF $PIECE(^DPT(APCHSPAT,0),U,2)'="F"
QUIT
+4 IF 'APCHSCRI
IF APCHSAGE<65
QUIT
+5 ;return in APCHSINT the frequency in days for this age/sex
IF APCHSCRI
SET APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT)
+6 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+7 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
DO OSTOWT
QUIT
+8 SET A=$$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)
+9 IF 'APCHHOST
Begin DoDot:1
+10 ;HAD ONE AFTER AGE 65
IF APCHLAST'<A
QUIT
+11 SET APCHNEXT=A
+12 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+13 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+14 DO OSTOWT
End DoDot:1
QUIT
+15 IF APCHHOST
Begin DoDot:1
+16 ;every 2 years
+17 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+18 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+19 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+20 DO OSTOWT
End DoDot:1
QUIT
+21 QUIT
+22 ;
AOFOWT ;
+1 KILL APCHV
+2 DO WRITE^APCHSMU
+3 XECUTE APCHSURX
+4 QUIT
AOF ;EP - AOF
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+3 SET APCHICAR=$$LASTAOF^APCLAPI4(APCHSPAT,,,"A")
+4 SET APCHLAST=$PIECE(APCHICAR,U,1)
+5 SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
+6 IF $PIECE(APCHOVR,U)>APCHLAST
Begin DoDot:1
+7 SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+8 DO WRITE^APCHSMU
+9 XECUTE APCHSURX
+10 QUIT
End DoDot:1
QUIT
AOFOREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF 'APCHSCRI
IF APCHSAGE>64
SET APCHSINT=365
SET APCHMIN=65
+3 IF 'APCHSCRI
IF APCHSAGE<65
QUIT
+4 ;return in APCHSINT the frequency in days for this age/sex
IF APCHSCRI
SET APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT)
SET APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
+5 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+6 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
DO AOFOWT
QUIT
+7 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+8 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+9 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+10 DO AOFOWT
+11 QUIT
CHLEOREF ;
+1 SET X=""
KILL APCHLSTR
SET APCHLSTR=""
+2 SET APCHT=$ORDER(^ATXAX("B","BGP CHLAMYDIA CPTS",0))
+3 IF APCHT
SET V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT)
IF V]""
DO SETR
+4 IF APCHLSTR]""
SET X=$GET(APCHLSTR(1))
DO S(X)
SET X=$GET(APCHLSTR(2))
IF X]""
DO S(X)
+5 SET APCHTAXN=$ORDER(^ATXLAB("B","BGP CHLAMYDIA TESTS TAX",0))
DO REF^APCHSM02
+6 QUIT
+7 ;
CHLOWT ;
+1 KILL APCHV
+2 DO CHLEOREF
+3 DO WRITE^APCHSMU
+4 XECUTE APCHSURX
+5 QUIT
CHLEO ;EP - CHLAMYDIA screening
+1 ;females only
IF $PIECE(^DPT(APCHSPAT,0),U,2)'="F"
QUIT
+2 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+3 NEW D,APCH16BD,APCH25BD,APCH26BD
+4 SET D=$PIECE(^DPT(DFN,0),U,3)
+5 SET APCH16BD=$EXTRACT(D,1,3)+16_$EXTRACT(D,4,7)
+6 SET APCH26BD=$EXTRACT(D,1,3)+26_$EXTRACT(D,4,7)
SET APCH25BD=$$FMADD^XLFDT(APCH26BD,-1)
+7 ;had CHLAMYDIA dx in past year so don't prompt
IF $$LASTDX^APCHSMU2(APCHSPAT,"BKM CHLAMYDIA DXS",$$FMADD^XLFDT(DT,-365),DT)
QUIT
+8 ;I $$PLTAX^APCHSMU(APCHSPAT,"BKM CHLAMYDIA DXS") Q ;chlamydia on problem list -NO per Susan
+9 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+10 SET APCHICAR=$$LASTCHLA^APCLAPI5(APCHSPAT,,DT,"A")
+11 SET APCHLAST=$PIECE(APCHICAR,U,1)
+12 SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
+13 IF $PIECE(APCHOVR,U)>APCHLAST
Begin DoDot:1
+14 SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+15 DO CHLEOREF
+16 DO WRITE^APCHSMU
+17 XECUTE APCHSURX
+18 QUIT
End DoDot:1
QUIT
CHLOREG ;regular stuff
+1 ;S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF APCHSAGE>25
QUIT
+3 IF APCHSAGE<16
QUIT
+4 ;I $$LASTCHLA^APCLAPI5(APCHSPAT,,DT)]"" Q
+5 SET APCHSINT=365
+6 ;I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT) ;return in APCHSINT the frequency in days for this age/sex
+7 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+8 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU(APCH16BD)
DO CHLOWT
QUIT
+9 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+10 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+11 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+12 DO CHLOWT
+13 QUIT
+14 ;
HIVEOREF ;
+1 SET X=""
KILL APCHLSTR
SET APCHLSTR=""
+2 SET APCHT=$ORDER(^ATXAX("B","BGP CPT HIV TESTS",0))
+3 IF APCHT
SET V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT)
IF V]""
DO SETR
+4 IF APCHLSTR]""
SET X=$GET(APCHLSTR(1))
DO S(X)
SET X=$GET(APCHLSTR(2))
IF X]""
DO S(X)
+5 SET APCHTAXN=$ORDER(^ATXLAB("B","BGP HIV TEST TAX",0))
DO REF^APCHSM02
+6 QUIT
+7 ;
HIVOWT ;
+1 KILL APCHV
+2 DO HIVEOREF
+3 DO WRITE^APCHSMU
+4 XECUTE APCHSURX
+5 QUIT
HIVSCR ;EP - HIV screening
+1 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+2 ;had HIV dx
IF $$LASTDX^APCHSMU2(APCHSPAT,"BGP HIV/AIDS DXS",$PIECE(^DPT(DFN,0),U,3),DT)
QUIT
+3 ;HIV on problem list
IF $$PLTAX^APCHSMU(APCHSPAT,"BGP HIV/AIDS DXS",,1)
XECUTE APCHSURX
QUIT
+4 IF $$IPLSNO^APCHSMU1(APCHSPAT,"PXRM HIV",1)
XECUTE APCHSURX
QUIT
+5 NEW D,APCH13BD,APCH65BD,APCH64BD
+6 SET D=$PIECE(^DPT(DFN,0),U,3)
+7 SET APCH13BD=$EXTRACT(D,1,3)+13_$EXTRACT(D,4,7)
+8 SET APCH65BD=$EXTRACT(D,1,3)+65_$EXTRACT(D,4,7)
SET APCH64BD=$$FMADD^XLFDT(APCH65BD,-1)
+9 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+10 SET APCHICAR=$$LASTHIVS^APCLAPI5(APCHSPAT,APCH13BD,APCH64BD,"A")
+11 SET APCHLAST=$PIECE(APCHICAR,U,1)
+12 SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
+13 IF $PIECE(APCHOVR,U)>APCHLAST
Begin DoDot:1
+14 SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+15 DO HIVEOREF
+16 DO WRITE^APCHSMU
+17 XECUTE APCHSURX
+18 QUIT
End DoDot:1
QUIT
HIVOREG ;regular stuff
+1 ;,APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
SET APCHSINT=1
+2 IF APCHSAGE>64
QUIT
+3 IF APCHSAGE<13
QUIT
+4 IF APCHLAST]""
QUIT
+5 SET APCHSINT=1
+6 ;I APCHSCRI S APCHSINT=$$AGESEX^APCHSMU(APCHSITI,APCHSPAT) ;return in APCHSINT the frequency in days for this age/sex
+7 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+8 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU(APCH13BD)
DO HIVOWT
QUIT
+9 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+10 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+11 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+12 DO HIVOWT
+13 QUIT
+14 ;
