APCHSM07.m

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)