APCHSM07 ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;
;;2.0;IHS PCC SUITE;**2,16**;MAY 14, 2009;Build 9
;
; ******************** 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
SIGMOID ;EP
X APCHSURX
S APCHNUMD=0
;this reminder works a little differently than the rest
;site cannot specify freguency, just age/sex
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
I $$PLTAX^APCHSMU(APCHSPAT,"BGP COLORECTAL CANCER DXS") X APCHSURX Q ;cancel if cancer on pl
I $$IPLSNO^APCHSMU1(APCHSPAT,"PXRM COLORECTAL CANCER") X APCHSURX Q ;cancel if pt has snomed htn on pl
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I APCHSCRI Q:'$$AGESEX^APCHSMU(APCHSITI,APCHSPAT,1)
I APCHSCRI S APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT) ;if there is site criteria then quit if patient is not in their defined age/sex range
I 'APCHSCRI Q:APCHSAGE<50 ;if ihs criteria used, quit if not 50
I 'APCHSCRI Q:APCHSAGE>75
I 'APCHSCRI S APCHMIN=50
S APCHLAST="",APCHNEXT="" K APCHSTEX
S APCHLSIC=$$LASTFSIG^APCLAPI(APCHSPAT,,,"A")
S APCHLSIG=$P(APCHLSIC,U,1)
S APCHLCOI=$$LASTCOLO^APCLAPI(APCHSPAT,,,"A")
S APCHLCOL=$P(APCHLCOI,U,1)
;S APCHLBEI=$$LASTBE^APCLAPI4(APCHSPAT,,,"A")
;S APCHLBE=$P(APCHLBEI,U,1)
;get last one of all
S APCHLAST=APCHLSIG,APCHICAR=APCHLSIC
I APCHLCOL>APCHLAST S APCHLAST=APCHLCOL,APCHICAR=APCHLCOI
;I APCHLBE>APCHLAST S APCHLAST=APCHLBE,APCHICAR=APCHLBEI
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)
.S X="" D SIGREF
.D WRITE^APCHSMU
.X APCHSURX
.Q
;reset and only use dates in time window (5 yrs sig, 10 yrs be&colo
I APCHLSIG]"",$$FMDIFF^XLFDT(DT,APCHLSIG)>(5*365) S APCHLSIG="",APCHLSIC=""
I APCHLCOL]"",$$FMDIFF^XLFDT(DT,APCHLCOL)>(10*365) S APCHLCOL="",APCHLCOI=""
;I APCHLBE]"",$$FMDIFF^XLFDT(DT,APCHLBE)>(10*365) S APCHLBE="",APCHLBEI=""
;get last one of all
S APCHLAST=APCHLSIG,APCHICAR=APCHLSIC
I APCHLCOL>APCHLAST S APCHLAST=APCHLCOL,APCHICAR=APCHLCOI
;I APCHLBE>APCHLAST S APCHLAST=APCHLBE,APCHICAR=APCHLBEI
I APCHLSIG]"" S APCHNUMD=APCHNUMD+1
I APCHLCOL]"" S APCHNUMD=APCHNUMD+1
;I APCHLBE]"" S APCHNUMD=APCHNUMD+1
SIGMOIDR ;
I APCHLAST="" S APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN)) D Q
.S X=""
.D SIGREF
.D WRITE^APCHSMU
.X APCHSURX
.Q
I APCHNUMD=1 D Q
.S APCHTEST=$S(APCHLSIG]"":"FLEXIBLE SIG",APCHLCOL]"":"COLONOSCOPY",1:"BARIUM ENEMA")
.S APCHSINT=$S(APCHLSIG]"":(5*365),1:(10*365))
.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 SIGREF
.D WRITE
.X APCHSURX
I APCHNUMD>1 D
.S APCHSTEX(1)="CLINICAL DECISION"
.D SIGREF
.D WRITALL
.X APCHSURX
X APCHSURX
Q
;
SETR ;
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
SIGREF ;
S X="" K APCHLSTR S APCHLSTR=""
I X="" S V=$$REF^APCHSMU(APCHSPAT,80.1,$O(^ICD0("BA",45.24,0)),APCHLAST) I V]"" D SETR
;I X="" S V=$$REF^APCHSMU(APCHSPAT,80.1,$O(^ICD0("BA",87.64,0)),APCHLAST) I V]"" D SETR
I X="" S V=$$REF^APCHSMU(APCHSPAT,80.1,$O(^ICD0("BA",45.21,0)),APCHLAST) I V]"" D SETR
I X="" S V=$$REF^APCHSMU(APCHSPAT,80.1,$O(^ICD0("BA",45.22,0)),APCHLAST) I V]"" D SETR
I X="" S V=$$REF^APCHSMU(APCHSPAT,80.1,$O(^ICD0("BA",45.23,0)),APCHLAST) I V]"" D SETR
I X="" S V=$$REF^APCHSMU(APCHSPAT,80.1,$O(^ICD0("BA",45.25,0)),APCHLAST) I V]"" D SETR
I X="" S V=$$REF^APCHSMU(APCHSPAT,80.1,$O(^ICD0("BA",45.42,0)),APCHLAST) I V]"" D SETR
S APCHT=$O(^ATXAX("B","BGP SIG CPTS",0))
I APCHT S V=$$RADREF^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT) I V]"" D SETR
S APCHT=$O(^ATXAX("B","BGP BE CPTS",0))
I APCHT S V=$$RADREF^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT) I V]"" D SETR
S APCHT=$O(^ATXAX("B","BGP COLO CPTS",0))
I APCHT S V=$$RADREF^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT) I V]"" D SETR
S APCHT=$O(^ATXAX("B","BGP SIG CPTS",0))
I APCHT S V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT) I V]"" D SETR
S APCHT=$O(^ATXAX("B","BGP BE CPTS",0))
I APCHT S V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT) I V]"" D SETR
S APCHT=$O(^ATXAX("B","BGP COLO 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
REF ;
K APCHREF S APCHT=0 F S APCHT=$O(^ATXLAB(APCHTAXN,21,"B",APCHT)) Q:APCHT'=+APCHT D
.S V=$$REF^APCHSMU(APCHSPAT,60,APCHT,APCHLAST) I V]"" S APCHREF(9999999-$P(V,U,3))=V
I $D(APCHREF) S %=0,%=$O(APCHREF(%)) I % S V=APCHREF(%),X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
Q
WRITALL ;
I $G(APCHSGHR) D Q
.S X="FLEXIBLE SIG"_U_APCHLSIG_U_$$DATE^APCHSMU(APCHLSIG)_U_"CLINICAL DISCRETION"_U_U_$P(APCHLSIC,U,4,99)
.S APCHSGHR(1)=X
.S X="COLONOSCOPY"_U_APCHLCOL_U_$$DATE^APCHSMU(APCHLCOL)_U_"CLINICAL DISCRETION"_U_U_$P(APCHLCOI,U,4,99)
.S $P(APCHSGHR(1),"|",2)=X
.;S X="BARIUM ENEMA"_U_APCHLBE_U_$$DATE^APCHSMU(APCHLBE)_U_"CLINICAL DISCRETION"_U_U_$P(APCHLBEI,U,4,99)
.S $P(APCHSGHR(1),"|",3)=X
I 'APCHSANY D FIRST^APCHSMU Q:$D(APCHSQIT) S APCHSANY=1,APCHSNGP=0
X APCHSCKP Q:$D(APCHSQIT)
I APCHSNPG W ?26,"LAST",?38,"NEXT",! S APCHSCT=0
W !,$P(^APCHSURV(APCHSITI,0),U)
W !?5,"FLEXIBLE SIG",?26,$$DATE^APCHSMU(APCHLSIG)
;W ?36,APCHSTEX(1) F APCHSL=2:1 Q:'$D(APCHSTEX(APCHSL)) W !,?36,APCHSTEX(APCHSL)
X APCHSCKP Q:$D(APCHSQIT)
I APCHSNPG W ?26,"LAST",?38,"NEXT" S APCHSCT=0
W !?5,"COLONOSCOPY",?26,$$DATE^APCHSMU(APCHLCOL)
X APCHSCKP Q:$D(APCHSQIT)
I APCHSNPG W ?26,"LAST",?38,"NEXT" S APCHSCT=0
;W !?5,"BARIUM ENEMA",?26,$$DATE^APCHSMU(APCHLBE)
I $D(APCHSTEX) D
.W ?36,APCHSTEX(1) F APCHSL=2:1 Q:'$D(APCHSTEX(APCHSL)) W !,?36,APCHSTEX(APCHSL)
S APCHSCT=APCHSCT+1
I '(APCHSCT#2) X APCHSCKP Q:$D(APCHSQIT) W:'APCHSNPG !
K APCHSTEX Q
WRITE ;EP - write out reminder
I $G(APCHSGHR) D Q
.NEW A,B
.S B=APCHTEST_" "
.S APCHSGHR(1)=$S($P(^APCHSURV(APCHSITI,0),U,4)]"":$P(^APCHSURV(APCHSITI,0),U,4),1:$P(^APCHSURV(APCHSITI,0),U))
.S APCHSGHR(2)=$G(APCHLAST)
.S APCHSGHR(3)=$$DATE^APCHSMU($G(APCHLAST))
.S A=0 F S A=$O(APCHSTEX(A)) Q:A'=+A S B=B_" "_APCHSTEX(A)
.S APCHSGHR(4)=B
.S APCHSGHR(5)=$G(APCHNEXT)
.S APCHSGHR(6)=$P($G(APCHICAR),U,4)
.S APCHSGHR(7)=$P($G(APCHICAR),U,5)
.S APCHSGHR(8)=$P($G(APCHICAR),U,6)
I 'APCHSANY D FIRST^APCHSMU Q:$D(APCHSQIT) S APCHSANY=1,APCHSNPG=0
X APCHSCKP Q:$D(APCHSQIT)
I APCHSNPG W ?26,"LAST",?38,"NEXT",! S APCHSCT=0
W !,$P(^APCHSURV(APCHSITI,0),U)
W !?5,APCHTEST,?26,$$DATE^APCHSMU(APCHLAST)
W ?36,APCHSTEX(1) F APCHSL=2:1 Q:'$D(APCHSTEX(APCHSL)) W !,?36,APCHSTEX(APCHSL)
S APCHSCT=APCHSCT+1
I '(APCHSCT#2) X APCHSCKP Q:$D(APCHSQIT) W:'APCHSNPG !
K APCHSTEX Q
;
FRA ;EP - fall risk assessment reminder
;yearly in 65 and older patients
;
;if this is turned off, quit
NEW V,X,Y
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHLAST="",APCHNEXT="" K APCHSTEX
;get date of last FALL RISK
S APCHICAR=$$LASTFRA^APCLAPI2(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)
.S APCHLR=""
.S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","37",0)),APCHLAST) I V]"" S APCHLR=V
.I APCHLR]"" S X=$P(APCHLR,U) D S(X) S X=$P(APCHLR,U,2) I X]"" D S(X)
.D WRITE^APCHSMU
.X APCHSURX
.Q
FALLREG ;regular stuff
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I 'APCHSCRI D
.Q:APCHSAGE<65
.S APCHSINT=365
.S APCHMIN=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 Q
.S APCHLR=""
.S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","37",0)),APCHLAST) I V]"" S APCHLR=V
.I APCHLR]"" S X=$P(APCHLR,U) D S(X) S X=$P(APCHLR,U,2) I X]"" D S(X)
.D WRITE^APCHSMU
.X APCHSURX
.Q
S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D Q
.S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","37",0)),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
I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D Q
.S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","37",0)),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
Q
;
EPSDT ;EP - EPSDT, copied from ANMC per Cimtac request
;if this is turned off, quit
X APCHSURX
NEW V,X,Y
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHLAST="",APCHNEXT="" K APCHSTEX
;get date of EPSDT CPT according to age of patient
S APCHICAR=$$LASTEPS^APCLAPI3(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
EPSREG ;regular stuff
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I 'APCHSCRI D
.Q:APCHSAGE>20
.S APCHSINT=365
.S APCHMIN=0
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 Q
.D WRITE^APCHSMU
.X APCHSURX
.Q
S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D Q
.D WRITE^APCHSMU
.X APCHSURX
.Q
I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D Q
.D WRITE^APCHSMU
.X APCHSURX
.Q
Q
DENTAL ;EP - DENTAL EXAM, yearly
;
;if this is turned off, quit
NEW V,X,Y
Q:'$$INAC^APCHSMU(APCHSITI) ;is item turned on or off
S APCHLAST="",APCHNEXT="" K APCHSTEX
;get date of last FALL RISK
S APCHICAR=$$LASTDENT^APCLAPI2(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)
.S APCHLR=""
.S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","30",0)),APCHLAST) I V]"" S APCHLR=V
.I APCHLR]"" S X=$P(APCHLR,U) D S(X) S X=$P(APCHLR,U,2) I X]"" D S(X)
.D WRITE^APCHSMU
.X APCHSURX
.Q
DENTREG ;regular stuff
S APCHSINT="",APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
I 'APCHSCRI D
.S APCHSINT=365
.S APCHMIN=1
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 Q
.S APCHLR=""
.S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","30",0)),APCHLAST) I V]"" S APCHLR=V
.I APCHLR]"" S X=$P(APCHLR,U) D S(X) S X=$P(APCHLR,U,2) I X]"" D S(X)
.D WRITE^APCHSMU
.X APCHSURX
.Q
S APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
I APCHNEXT>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D Q
.S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","30",0)),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
I APCHNEXT'>DT S APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT) D Q
.S V=$$REF^APCHSMU(APCHSPAT,9999999.15,$O(^AUTTEXAM("C","30",0)),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
Q
;
APCHSM07 ; IHS/CMI/LAB -- CONTINUATION OF ROUTINES ;
+1 ;;2.0;IHS PCC SUITE;**2,16**;MAY 14, 2009;Build 9
+2 ;
+3 ; ******************** 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
SIGMOID ;EP
+1 XECUTE APCHSURX
+2 SET APCHNUMD=0
+3 ;this reminder works a little differently than the rest
+4 ;site cannot specify freguency, just age/sex
+5 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+6 ;cancel if cancer on pl
IF $$PLTAX^APCHSMU(APCHSPAT,"BGP COLORECTAL CANCER DXS")
XECUTE APCHSURX
QUIT
+7 ;cancel if pt has snomed htn on pl
IF $$IPLSNO^APCHSMU1(APCHSPAT,"PXRM COLORECTAL CANCER")
XECUTE APCHSURX
QUIT
+8 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+9 IF APCHSCRI
IF '$$AGESEX^APCHSMU(APCHSITI,APCHSPAT,1)
QUIT
+10 ;if there is site criteria then quit if patient is not in their defined age/sex range
IF APCHSCRI
SET APCHMIN=$$MINAGE^APCHSMU(APCHSITI,APCHSPAT)
+11 ;if ihs criteria used, quit if not 50
IF 'APCHSCRI
IF APCHSAGE<50
QUIT
+12 IF 'APCHSCRI
IF APCHSAGE>75
QUIT
+13 IF 'APCHSCRI
SET APCHMIN=50
+14 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+15 SET APCHLSIC=$$LASTFSIG^APCLAPI(APCHSPAT,,,"A")
+16 SET APCHLSIG=$PIECE(APCHLSIC,U,1)
+17 SET APCHLCOI=$$LASTCOLO^APCLAPI(APCHSPAT,,,"A")
+18 SET APCHLCOL=$PIECE(APCHLCOI,U,1)
+19 ;S APCHLBEI=$$LASTBE^APCLAPI4(APCHSPAT,,,"A")
+20 ;S APCHLBE=$P(APCHLBEI,U,1)
+21 ;get last one of all
+22 SET APCHLAST=APCHLSIG
SET APCHICAR=APCHLSIC
+23 IF APCHLCOL>APCHLAST
SET APCHLAST=APCHLCOL
SET APCHICAR=APCHLCOI
+24 ;I APCHLBE>APCHLAST S APCHLAST=APCHLBE,APCHICAR=APCHLBEI
+25 SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
+26 IF $PIECE(APCHOVR,U)>APCHLAST
Begin DoDot:1
+27 SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+28 SET X=""
DO SIGREF
+29 DO WRITE^APCHSMU
+30 XECUTE APCHSURX
+31 QUIT
End DoDot:1
QUIT
+32 ;reset and only use dates in time window (5 yrs sig, 10 yrs be&colo
+33 IF APCHLSIG]""
IF $$FMDIFF^XLFDT(DT,APCHLSIG)>(5*365)
SET APCHLSIG=""
SET APCHLSIC=""
+34 IF APCHLCOL]""
IF $$FMDIFF^XLFDT(DT,APCHLCOL)>(10*365)
SET APCHLCOL=""
SET APCHLCOI=""
+35 ;I APCHLBE]"",$$FMDIFF^XLFDT(DT,APCHLBE)>(10*365) S APCHLBE="",APCHLBEI=""
+36 ;get last one of all
+37 SET APCHLAST=APCHLSIG
SET APCHICAR=APCHLSIC
+38 IF APCHLCOL>APCHLAST
SET APCHLAST=APCHLCOL
SET APCHICAR=APCHLCOI
+39 ;I APCHLBE>APCHLAST S APCHLAST=APCHLBE,APCHICAR=APCHLBEI
+40 IF APCHLSIG]""
SET APCHNUMD=APCHNUMD+1
+41 IF APCHLCOL]""
SET APCHNUMD=APCHNUMD+1
+42 ;I APCHLBE]"" S APCHNUMD=APCHNUMD+1
SIGMOIDR ;
+1 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
Begin DoDot:1
+2 SET X=""
+3 DO SIGREF
+4 DO WRITE^APCHSMU
+5 XECUTE APCHSURX
+6 QUIT
End DoDot:1
QUIT
+7 IF APCHNUMD=1
Begin DoDot:1
+8 SET APCHTEST=$SELECT(APCHLSIG]"":"FLEXIBLE SIG",APCHLCOL]"":"COLONOSCOPY",1:"BARIUM ENEMA")
+9 SET APCHSINT=$SELECT(APCHLSIG]"":(5*365),1:(10*365))
+10 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+11 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+12 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
+13 DO SIGREF
+14 DO WRITE
+15 XECUTE APCHSURX
End DoDot:1
QUIT
+16 IF APCHNUMD>1
Begin DoDot:1
+17 SET APCHSTEX(1)="CLINICAL DECISION"
+18 DO SIGREF
+19 DO WRITALL
+20 XECUTE APCHSURX
End DoDot:1
+21 XECUTE APCHSURX
+22 QUIT
+23 ;
SETR ;
+1 IF APCHLSTR>$PIECE(V,U,3)
QUIT
+2 SET APCHLSTR=$PIECE(V,U,3)
+3 SET APCHLSTR(1)=$PIECE(V,U,1)
+4 SET APCHLSTR(2)=$PIECE(V,U,2)
+5 QUIT
SIGREF ;
+1 SET X=""
KILL APCHLSTR
SET APCHLSTR=""
+2 IF X=""
SET V=$$REF^APCHSMU(APCHSPAT,80.1,$ORDER(^ICD0("BA",45.24,0)),APCHLAST)
IF V]""
DO SETR
+3 ;I X="" S V=$$REF^APCHSMU(APCHSPAT,80.1,$O(^ICD0("BA",87.64,0)),APCHLAST) I V]"" D SETR
+4 IF X=""
SET V=$$REF^APCHSMU(APCHSPAT,80.1,$ORDER(^ICD0("BA",45.21,0)),APCHLAST)
IF V]""
DO SETR
+5 IF X=""
SET V=$$REF^APCHSMU(APCHSPAT,80.1,$ORDER(^ICD0("BA",45.22,0)),APCHLAST)
IF V]""
DO SETR
+6 IF X=""
SET V=$$REF^APCHSMU(APCHSPAT,80.1,$ORDER(^ICD0("BA",45.23,0)),APCHLAST)
IF V]""
DO SETR
+7 IF X=""
SET V=$$REF^APCHSMU(APCHSPAT,80.1,$ORDER(^ICD0("BA",45.25,0)),APCHLAST)
IF V]""
DO SETR
+8 IF X=""
SET V=$$REF^APCHSMU(APCHSPAT,80.1,$ORDER(^ICD0("BA",45.42,0)),APCHLAST)
IF V]""
DO SETR
+9 SET APCHT=$ORDER(^ATXAX("B","BGP SIG CPTS",0))
+10 IF APCHT
SET V=$$RADREF^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT)
IF V]""
DO SETR
+11 SET APCHT=$ORDER(^ATXAX("B","BGP BE CPTS",0))
+12 IF APCHT
SET V=$$RADREF^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT)
IF V]""
DO SETR
+13 SET APCHT=$ORDER(^ATXAX("B","BGP COLO CPTS",0))
+14 IF APCHT
SET V=$$RADREF^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT)
IF V]""
DO SETR
+15 SET APCHT=$ORDER(^ATXAX("B","BGP SIG CPTS",0))
+16 IF APCHT
SET V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT)
IF V]""
DO SETR
+17 SET APCHT=$ORDER(^ATXAX("B","BGP BE CPTS",0))
+18 IF APCHT
SET V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT)
IF V]""
DO SETR
+19 SET APCHT=$ORDER(^ATXAX("B","BGP COLO CPTS",0))
+20 IF APCHT
SET V=$$CPTREFT^APCHSMU2(APCHSPAT,APCHLAST,DT,APCHT)
IF V]""
DO SETR
+21 IF APCHLSTR]""
SET X=$GET(APCHLSTR(1))
DO S(X)
SET X=$GET(APCHLSTR(2))
IF X]""
DO S(X)
+22 QUIT
REF ;
+1 KILL APCHREF
SET APCHT=0
FOR
SET APCHT=$ORDER(^ATXLAB(APCHTAXN,21,"B",APCHT))
IF APCHT'=+APCHT
QUIT
Begin DoDot:1
+2 SET V=$$REF^APCHSMU(APCHSPAT,60,APCHT,APCHLAST)
IF V]""
SET APCHREF(9999999-$PIECE(V,U,3))=V
End DoDot:1
+3 IF $DATA(APCHREF)
SET %=0
SET %=$ORDER(APCHREF(%))
IF %
SET V=APCHREF(%)
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+4 QUIT
WRITALL ;
+1 IF $GET(APCHSGHR)
Begin DoDot:1
+2 SET X="FLEXIBLE SIG"_U_APCHLSIG_U_$$DATE^APCHSMU(APCHLSIG)_U_"CLINICAL DISCRETION"_U_U_$PIECE(APCHLSIC,U,4,99)
+3 SET APCHSGHR(1)=X
+4 SET X="COLONOSCOPY"_U_APCHLCOL_U_$$DATE^APCHSMU(APCHLCOL)_U_"CLINICAL DISCRETION"_U_U_$PIECE(APCHLCOI,U,4,99)
+5 SET $PIECE(APCHSGHR(1),"|",2)=X
+6 ;S X="BARIUM ENEMA"_U_APCHLBE_U_$$DATE^APCHSMU(APCHLBE)_U_"CLINICAL DISCRETION"_U_U_$P(APCHLBEI,U,4,99)
+7 SET $PIECE(APCHSGHR(1),"|",3)=X
End DoDot:1
QUIT
+8 IF 'APCHSANY
DO FIRST^APCHSMU
IF $DATA(APCHSQIT)
QUIT
SET APCHSANY=1
SET APCHSNGP=0
+9 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+10 IF APCHSNPG
WRITE ?26,"LAST",?38,"NEXT",!
SET APCHSCT=0
+11 WRITE !,$PIECE(^APCHSURV(APCHSITI,0),U)
+12 WRITE !?5,"FLEXIBLE SIG",?26,$$DATE^APCHSMU(APCHLSIG)
+13 ;W ?36,APCHSTEX(1) F APCHSL=2:1 Q:'$D(APCHSTEX(APCHSL)) W !,?36,APCHSTEX(APCHSL)
+14 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+15 IF APCHSNPG
WRITE ?26,"LAST",?38,"NEXT"
SET APCHSCT=0
+16 WRITE !?5,"COLONOSCOPY",?26,$$DATE^APCHSMU(APCHLCOL)
+17 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+18 IF APCHSNPG
WRITE ?26,"LAST",?38,"NEXT"
SET APCHSCT=0
+19 ;W !?5,"BARIUM ENEMA",?26,$$DATE^APCHSMU(APCHLBE)
+20 IF $DATA(APCHSTEX)
Begin DoDot:1
+21 WRITE ?36,APCHSTEX(1)
FOR APCHSL=2:1
IF '$DATA(APCHSTEX(APCHSL))
QUIT
WRITE !,?36,APCHSTEX(APCHSL)
End DoDot:1
+22 SET APCHSCT=APCHSCT+1
+23 IF '(APCHSCT#2)
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
WRITE !
+24 KILL APCHSTEX
QUIT
WRITE ;EP - write out reminder
+1 IF $GET(APCHSGHR)
Begin DoDot:1
+2 NEW A,B
+3 SET B=APCHTEST_" "
+4 SET APCHSGHR(1)=$SELECT($PIECE(^APCHSURV(APCHSITI,0),U,4)]"":$PIECE(^APCHSURV(APCHSITI,0),U,4),1:$PIECE(^APCHSURV(APCHSITI,0),U))
+5 SET APCHSGHR(2)=$GET(APCHLAST)
+6 SET APCHSGHR(3)=$$DATE^APCHSMU($GET(APCHLAST))
+7 SET A=0
FOR
SET A=$ORDER(APCHSTEX(A))
IF A'=+A
QUIT
SET B=B_" "_APCHSTEX(A)
+8 SET APCHSGHR(4)=B
+9 SET APCHSGHR(5)=$GET(APCHNEXT)
+10 SET APCHSGHR(6)=$PIECE($GET(APCHICAR),U,4)
+11 SET APCHSGHR(7)=$PIECE($GET(APCHICAR),U,5)
+12 SET APCHSGHR(8)=$PIECE($GET(APCHICAR),U,6)
End DoDot:1
QUIT
+13 IF 'APCHSANY
DO FIRST^APCHSMU
IF $DATA(APCHSQIT)
QUIT
SET APCHSANY=1
SET APCHSNPG=0
+14 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+15 IF APCHSNPG
WRITE ?26,"LAST",?38,"NEXT",!
SET APCHSCT=0
+16 WRITE !,$PIECE(^APCHSURV(APCHSITI,0),U)
+17 WRITE !?5,APCHTEST,?26,$$DATE^APCHSMU(APCHLAST)
+18 WRITE ?36,APCHSTEX(1)
FOR APCHSL=2:1
IF '$DATA(APCHSTEX(APCHSL))
QUIT
WRITE !,?36,APCHSTEX(APCHSL)
+19 SET APCHSCT=APCHSCT+1
+20 IF '(APCHSCT#2)
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
WRITE !
+21 KILL APCHSTEX
QUIT
+22 ;
FRA ;EP - fall risk assessment reminder
+1 ;yearly in 65 and older patients
+2 ;
+3 ;if this is turned off, quit
+4 NEW V,X,Y
+5 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+6 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+7 ;get date of last FALL RISK
+8 SET APCHICAR=$$LASTFRA^APCLAPI2(APCHSPAT,,,"A")
+9 SET APCHLAST=$PIECE(APCHICAR,U,1)
+10 SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
+11 IF $PIECE(APCHOVR,U)>APCHLAST
Begin DoDot:1
+12 SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+13 SET APCHLR=""
+14 SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","37",0)),APCHLAST)
IF V]""
SET APCHLR=V
+15 IF APCHLR]""
SET X=$PIECE(APCHLR,U)
DO S(X)
SET X=$PIECE(APCHLR,U,2)
IF X]""
DO S(X)
+16 DO WRITE^APCHSMU
+17 XECUTE APCHSURX
+18 QUIT
End DoDot:1
QUIT
FALLREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF 'APCHSCRI
Begin DoDot:1
+3 IF APCHSAGE<65
QUIT
+4 SET APCHSINT=365
+5 SET APCHMIN=65
End DoDot:1
+6 ;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)
+7 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+8 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
Begin DoDot:1
+9 SET APCHLR=""
+10 SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","37",0)),APCHLAST)
IF V]""
SET APCHLR=V
+11 IF APCHLR]""
SET X=$PIECE(APCHLR,U)
DO S(X)
SET X=$PIECE(APCHLR,U,2)
IF X]""
DO S(X)
+12 DO WRITE^APCHSMU
+13 XECUTE APCHSURX
+14 QUIT
End DoDot:1
QUIT
+15 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+16 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
Begin DoDot:1
+17 SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","37",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+18 DO WRITE^APCHSMU
+19 XECUTE APCHSURX
+20 QUIT
End DoDot:1
QUIT
+21 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
Begin DoDot:1
+22 SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","37",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+23 DO WRITE^APCHSMU
+24 XECUTE APCHSURX
+25 QUIT
End DoDot:1
QUIT
+26 QUIT
+27 ;
EPSDT ;EP - EPSDT, copied from ANMC per Cimtac request
+1 ;if this is turned off, quit
+2 XECUTE APCHSURX
+3 NEW V,X,Y
+4 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+5 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+6 ;get date of EPSDT CPT according to age of patient
+7 SET APCHICAR=$$LASTEPS^APCLAPI3(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 WRITE^APCHSMU
+13 XECUTE APCHSURX
+14 QUIT
End DoDot:1
QUIT
EPSREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF 'APCHSCRI
Begin DoDot:1
+3 IF APCHSAGE>20
QUIT
+4 SET APCHSINT=365
+5 SET APCHMIN=0
End DoDot:1
+6 ;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)
+7 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+8 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
Begin DoDot:1
+9 DO WRITE^APCHSMU
+10 XECUTE APCHSURX
+11 QUIT
End DoDot:1
QUIT
+12 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+13 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
Begin DoDot:1
+14 DO WRITE^APCHSMU
+15 XECUTE APCHSURX
+16 QUIT
End DoDot:1
QUIT
+17 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
Begin DoDot:1
+18 DO WRITE^APCHSMU
+19 XECUTE APCHSURX
+20 QUIT
End DoDot:1
QUIT
+21 QUIT
DENTAL ;EP - DENTAL EXAM, yearly
+1 ;
+2 ;if this is turned off, quit
+3 NEW V,X,Y
+4 ;is item turned on or off
IF '$$INAC^APCHSMU(APCHSITI)
QUIT
+5 SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+6 ;get date of last FALL RISK
+7 SET APCHICAR=$$LASTDENT^APCLAPI2(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 SET APCHLR=""
+13 SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","30",0)),APCHLAST)
IF V]""
SET APCHLR=V
+14 IF APCHLR]""
SET X=$PIECE(APCHLR,U)
DO S(X)
SET X=$PIECE(APCHLR,U,2)
IF X]""
DO S(X)
+15 DO WRITE^APCHSMU
+16 XECUTE APCHSURX
+17 QUIT
End DoDot:1
QUIT
DENTREG ;regular stuff
+1 SET APCHSINT=""
SET APCHSCRI=$$SITECRIT^APCHSMU(APCHSITI)
+2 IF 'APCHSCRI
Begin DoDot:1
+3 SET APCHSINT=365
+4 SET APCHMIN=1
End DoDot:1
+5 ;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)
+6 ;no frequency so skip it
IF APCHSINT=""
XECUTE APCHSURX
QUIT
+7 IF APCHLAST=""
SET APCHSTEX(1)=$$DATE^APCHSMU($$DATEAGE^APCHSMU(APCHSPAT,APCHMIN))
Begin DoDot:1
+8 SET APCHLR=""
+9 SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","30",0)),APCHLAST)
IF V]""
SET APCHLR=V
+10 IF APCHLR]""
SET X=$PIECE(APCHLR,U)
DO S(X)
SET X=$PIECE(APCHLR,U,2)
IF X]""
DO S(X)
+11 DO WRITE^APCHSMU
+12 XECUTE APCHSURX
+13 QUIT
End DoDot:1
QUIT
+14 SET APCHNEXT=$$FMADD^XLFDT(APCHLAST,APCHSINT)
+15 IF APCHNEXT>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
Begin DoDot:1
+16 SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","30",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+17 DO WRITE^APCHSMU
+18 XECUTE APCHSURX
+19 QUIT
End DoDot:1
QUIT
+20 IF APCHNEXT'>DT
SET APCHSTEX(1)=$$DATE^APCHSMU(APCHNEXT)
Begin DoDot:1
+21 SET V=$$REF^APCHSMU(APCHSPAT,9999999.15,$ORDER(^AUTTEXAM("C","30",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+22 DO WRITE^APCHSMU
+23 XECUTE APCHSURX
+24 QUIT
End DoDot:1
QUIT
+25 QUIT
+26 ;
