APCHS11C ; IHS/CMI/LAB - SECTION OF HEALTH SUMMARY ;
;;2.0;IHS PCC SUITE;**4,11**;MAY 14, 2009;Build 58
;IHS/CMI/LAB - fixed alcohol and tobacco reminder, added
;sigmoid subroutine, fixed for new imm package
;IHS/CMI/LAB - fixed tobacco and alcohol review reminders 11/17/98
;IHS/CMI/LAB - fixed error check in BI call
;cmi/anch/maw 8/27/2007 code set versioning in SIGMOID
;
; ******************** SURVEILLANCE - HARD CODE ********************
EN ;ENTRY POINT FOR HSUM PRINT OF IMMUNIZ HLTH MNT RMDR
;IHS/CMI/LAB - modified this subroutine to work with new BI package
I $$BI D Q ;IHS/CMI/LAB - new subroutine for new immpackage
.NEW APCHIMM,APCH31,APCHBIER ;IHS/CMI/LAB - PATCH 4
.D IMMFORC^BIRPC(.APCHIMM,APCHSPAT)
.S APCH31=$C(31)_$C(31) ;IHS/OKCAO/POC 1/11/00 SET APCH31
.S APCHBIER=$P(APCHIMM,APCH31,2)
.I $G(APCHSGHR) D Q
..S APCHSGHR(1)=$S($P(^APCHSURV(APCHSITI,0),U,4)]"":$P(^APCHSURV(APCHSITI,0),U,4),1:$P(^APCHSURV(APCHSITI,0),U))
..S APCHSGHR(4)=APCHIMM
.I APCHBIER]"" X APCHSCKP Q:$D(APCHSQIT) D Q
..D EN^DDIOL("IMMUNIZATIONS DUE * "_APCHBIER,"","!") W !
..Q
.S APCHIMM=$P(APCHIMM,APCH31,1) ;LETS GET RID OF CONTROL CHARACTERS BEFORE GOING ON IHS/OKCAO/POC 1/11/00
.NEW APCHX,APCHI F APCHX=1:1 S APCHI=$P(APCHIMM,"^",APCHX) Q:APCHI=""!($D(APCHSQIT)) D
..S APCHI=$$TRIM(APCHI)
..I $G(APCHSGHR) D Q
...S X=$P(APCHI,"|")_U_U_$P(APCHI,"|",2)_U_$P(APCHI,"|",3),$P(APCHSGHR,"|",APCHX)=X
..I 'APCHSANY D FIRST^APCHS11 Q:$D(APCHSQIT) S APCHSANY=1
..X APCHSCKP Q:$D(APCHSQIT)
..I APCHSNPG W ?26,"LAST",?38,"NEXT",!! S APCHSCT=0
..W:APCHX=1 ! W $P(APCHI,"|"),?24,$P(APCHI,"|",2),?36,$P(APCHI,"|",3),!
..I APCHI["VARICELLA" S X=$$PHCP^APCHS2(APCHSPAT) I X]"" D
...W ?2,"Patient has a Hx of Chicken pox not yet entered as a contraindication"
...W !?2,"in the Immunization Package.",!,?2,X,!
..Q
.Q
K W I $D(APCHSPAT) S:$D(X) APCHSSAV=X S X="AMCHPCC" X ^%ZOSF("TEST") S:$D(APCHSSAV) X=APCHSSAV K APCHSSAV I $T D ^AMCHPCC I 1 ; CHANGED HOW X SET PRIOR TO CALL TO ^%ZOSF("TEST") IHS/DWG 4/21/91
E Q
I $D(W),W]"" S APCHSDIS=W,APCHSDUE="MAY BE DUE NOW",APCHSDAT="" D DISPLAY^APCHS11
K APCHSDIS,APCHSDUE,APCHSDAT,APCHSTPZ,W
Q
;
;
BI() ;EP- check to see if using new imm package or not 1/5/1999 IHS/CMI/LAB
Q $S($O(^AUTTIMM(0))<100:0,1:1)
;end new subrotuine CMI/TUCSON/LAB
TDADULT ;ENTRY POINT - immunization TETANUS DIPTHERIA (Td-ADULT)
K APCHSTEX
Q:APCHSAGE<12
;Q:'$D(^AUPNVIMM("AC",APCHSPAT))
K APCHS
S (APCHSDAT,APCHSDUE)=""
S APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST IMM "_$S($$BI:9,1:"02"),"APCHS(") ;IHS/CMI/LAB - patch 3
G:APCHSERR TDADULTX
; *array APCHS(1)="DATE^SERIES^IMMUNIZATION^VIMM IEN;AUPNVIMM^VISIT IEN"
K APCHSERR
S APCHSDIS="Td-ADULT"
S APCHSINT=10*365
S APCHSIVD=$S($D(APCHS(1)):9999999-$P($P(APCHS(1),U,1),".",1),1:"")
S APCHSEXD=$S($$BI^APCHS11C:$O(^AUTTIMM("C",9,0)),1:$O(^AUTTIMM("C","02",0))),APCHSDF1=9999999.14
D DFSURV^APCHS11 ; computes/print immunization due date
TDADULTX ;
K APCHS,APCHSDF1,APCHSEXD,APCHSTEX
Q
;
;
FLU ;
K APCHSTEX
S (APCHSDAT,APCHSDUE)=""
K APCHSRSK
I $D(^ATXAX("B","SURVEILLANCE PNEUMOCOCCAL RISK")) S APCHSURP=$O(^ATXAX("B","SURVEILLANCE PNEUMOCOCCAL RISK","")) S:$D(^ATXPAT(APCHSURP,11,APCHSPAT)) APCHSRSK=""
S %=$$FMDIFF^XLFDT(DT,$P(^DPT(APCHSPAT,0),U,3),1)
I %<180 Q ;quit if patient is under 6 months old
G:(APCHSAGE<65)&('$D(APCHSRSK)) FLUX
S APCHSDIS="INFLUENZA"
S APCHSINT=365
;S APCHSFLX="INFLUENZA" ;IHS/CMI/LAB - commented out
;S APCHSFLX=$O(^AUTTIMM("B","INFLUENZA","")) ;IHS/CMI/LAB - commented out
;S:'APCHSFLX APCHSFLX=$O(^AUTTIMM("C",12,"")) ;IHS/CMI/LAB - commented out
S APCHSFLX=$S($$BI:$O(^AUTTIMM("C",88,"")),1:$O(^AUTTIMM("C",12,""))) ;IHS/CMI/LAB - new imm package patch 3
I 'APCHSFLX D G DSPLY
. S (APCHSDAT,APCHSDUE)=""
. S APCHSTEX(1)="Influenza immunization appears indicated,"
. S APCHSTEX(2)=" but INFLUENZA cannot be located in the"
. S APCHSTEX(3)=" immunization type file, so the patient's"
. S APCHSTEX(4)=" history cannot be evaluated."
S APCHSIVD=$O(^AUPNVIMM("AA",APCHSPAT,APCHSFLX,""))
I 'APCHSIVD S APCHSDUE="MAY BE DUE NOW",APCHSDAT="" G DSPLY
GETDATE ;
D COMPARE^APCHS11,GETDATE^APCHS11
DSPLY ;
S APCHSEXD=$S($$BI^APCHS11C:$O(^AUTTIMM("C",88,0)),1:$O(^AUTTIMM("C",12,0))),APCHSDF1=9999999.14 D REFDF^APCHS11
D DISPLAY^APCHS11
FLUX ;
K APCHSURP,APCHSRSK,APCHSFLX,APCHSTEX,APCHSEXD,APCHSDF1
Q
;
;
TOBACCO ;ENTRY POINT - annual REVIEW OF TOBACCO USE
Q:APCHSAGE<13 ;IHS/CMI/LAB 12/16/97
;
S APCHSCAT=$O(^AUTTHF("B","TOBACCO",""))
Q:'APCHSCAT ; tobacco category does not exist
S APCHSDIS="REVIEW OF TOBACCO USE"
S APCHSINT=365
D HFACTOR
TOBACCOX ;
Q
;
;
ALCOHOL ;ENTRY POINT - annual REVIEW OF ALCOHOL USE
Q:APCHSAGE<13 ;IHS/CMI/LAB 12/16/97
;
S APCHSCAT=$O(^AUTTHF("B","ALCOHOL",""))
Q:'APCHSCAT ; alcohol/drug category does not exist
S APCHSDIS="REVIEW OF ALCOHOL USE"
S APCHSINT=365
D HFACTOR
ALCOHOLX ;
Q
;
HFACTOR ;EP called from TOBACCO and ALCOHOL sub-rtns
;IHS/CMI/LAB - modified this subroutine patch 3
;this had to be modified to get the last of each category
;it was getting the last of the first factor it found within the
;category
S APCHSHFD=0
F S APCHSHFD=$O(^AUTTHF("AC",APCHSCAT,APCHSHFD)) Q:'+APCHSHFD D
. Q:'$D(^AUPNVHF("AA",APCHSPAT,APCHSHFD))
. S APCHSIVD=$O(^AUPNVHF("AA",APCHSPAT,APCHSHFD,""))
. Q:'APCHSIVD
. S APCHSONE(APCHSIVD)=""
. Q
I $D(APCHSONE) D
. S APCHSIVD=$O(APCHSONE(""))
. D COMPARE^APCHS11
. D GETDATE^APCHS11
. ;S APCHSONE=1
. Q
I '$D(APCHSONE) S APCHSDUE="MAY BE DUE NOW",APCHSDAT=""
D DISPLAY^APCHS11
HFACTORX ;
K APCHSONE
Q
;
;
PHYSCL ;ENTRY POINT - annual PHYSICAL EXAM
Q:'$D(^AUPNVPOV("AC",APCHSPAT))
K APCHS
S APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST DX [SURVEILLANCE PHYSICAL EXAM;","APCHS(")
G:APCHSERR PHYSCLX
; *array APCHS(1)="DATE^CODE^CODE^VPOV IEN;AUPNVPOV^VISIT IEN"
K APCHSERR
S APCHSDIS="PHYSICAL EXAM"
S APCHSINT=365
S APCHSIVD=$S($D(APCHS(1)):9999999-$P($P(APCHS(1),U,1),".",1),1:"")
D DFSURV^APCHS11 ; computes/print exam due date
PHYSCLX ;
K APCHS
Q
;
SIGMOID ;IHS/ANMC/LAB - added thisnew reminder per Dr. Murphy
;EVERY 5 YEARS AFTER AGE 50
Q:APCHSAGE<50
S APCHLAST="",APCHNEXT="" K APCHSTEX ;IHS/CMI/LAB - added for override
W ! ;IHS/ANMC/CLS 10/01/2002
NEW %,%1,D
K APCHSPRC
;cmi/anch/maw 8/27/2007 mods for code set versioning
N APCHSVDT
;S %=0 F S %=$O(^AUPNVPRC("AC",APCHSPAT,%)) Q:%'=+% S %1=$P(^ICD0($P(^AUPNVPRC(%,0),U),0),U) D
S %=0 F S %=$O(^AUPNVPRC("AC",APCHSPAT,%)) Q:%'=+% S APCHSVDT=$P(+^AUPNVSIT($P(^AUPNVPRC(%,0),U,3),0),"."),%1=$P($$ICDOP^ICDEX($P(^AUPNVPRC(%,0),U),APCHSVDT,,"I"),U,2) D
.I %1=48.23!(%1>45.20&(%1<45.26)) S D=$P($P(^AUPNVSIT($P(^AUPNVPRC(%,0),U,3),0),U),"."),APCHSPRC(9999999-D)=""
;S APCHSINT=365*5,APCHSDIS="SIGMOIDOSCOPY",APCHSIVD=$O(APCHSPRC("")) ;IHS/ANMC/CLS 02/25/01 IHS/CMI/LAB - replaced for override
;cmi/anch/maw 8/27/2007 end of mods
S APCHLAST=$O(APCHSPRC(0)) I APCHLAST]"" S APCHLAST=9999999-APCHLAST ;IHS/CMI/LAB - added for override
;IHS/CMI/LAB - added lines below for override
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 SIGWT
.Q
S APCHSINT=365*5,APCHSDIS="COLORECTAL SCREENING",APCHSIVD=$O(APCHSPRC("")) ;IHS/ANMC/CLS 02/25/01
I 'APCHSIVD S APCHSDUE="MAY BE DUE NOW",APCHSDAT="" D DISPLAY^APCHS11 X APCHSURX Q
D GETDATE^APCHS11,COMPARE^APCHS11,DISPLAY^APCHS11 X APCHSURX
Q
TRIM(X) ;EP
;---> TRIM OFF ANY LEADING SPACES.
Q:'$D(X) ""
N I,L S L=$L(X)
F I=1:1 Q:$E(X,I)'=" "
Q $E(X,I,L)
SIGWT ;
D WRITE^APCHSMU
X APCHSURX
Q
;
S(X) ;
NEW %,C S (C,%)=0 F S %=$O(APCHSTEX(%)) Q:%'=+% S C=C+1
S APCHSTEX(C+1)=X
Q
APCHS11C ; IHS/CMI/LAB - SECTION OF HEALTH SUMMARY ;
+1 ;;2.0;IHS PCC SUITE;**4,11**;MAY 14, 2009;Build 58
+2 ;IHS/CMI/LAB - fixed alcohol and tobacco reminder, added
+3 ;sigmoid subroutine, fixed for new imm package
+4 ;IHS/CMI/LAB - fixed tobacco and alcohol review reminders 11/17/98
+5 ;IHS/CMI/LAB - fixed error check in BI call
+6 ;cmi/anch/maw 8/27/2007 code set versioning in SIGMOID
+7 ;
+8 ; ******************** SURVEILLANCE - HARD CODE ********************
EN ;ENTRY POINT FOR HSUM PRINT OF IMMUNIZ HLTH MNT RMDR
+1 ;IHS/CMI/LAB - modified this subroutine to work with new BI package
+2 ;IHS/CMI/LAB - new subroutine for new immpackage
IF $$BI
Begin DoDot:1
+3 ;IHS/CMI/LAB - PATCH 4
NEW APCHIMM,APCH31,APCHBIER
+4 DO IMMFORC^BIRPC(.APCHIMM,APCHSPAT)
+5 ;IHS/OKCAO/POC 1/11/00 SET APCH31
SET APCH31=$CHAR(31)_$CHAR(31)
+6 SET APCHBIER=$PIECE(APCHIMM,APCH31,2)
+7 IF $GET(APCHSGHR)
Begin DoDot:2
+8 SET APCHSGHR(1)=$SELECT($PIECE(^APCHSURV(APCHSITI,0),U,4)]"":$PIECE(^APCHSURV(APCHSITI,0),U,4),1:$PIECE(^APCHSURV(APCHSITI,0),U))
+9 SET APCHSGHR(4)=APCHIMM
End DoDot:2
QUIT
+10 IF APCHBIER]""
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
Begin DoDot:2
+11 DO EN^DDIOL("IMMUNIZATIONS DUE * "_APCHBIER,"","!")
WRITE !
+12 QUIT
End DoDot:2
QUIT
+13 ;LETS GET RID OF CONTROL CHARACTERS BEFORE GOING ON IHS/OKCAO/POC 1/11/00
SET APCHIMM=$PIECE(APCHIMM,APCH31,1)
+14 NEW APCHX,APCHI
FOR APCHX=1:1
SET APCHI=$PIECE(APCHIMM,"^",APCHX)
IF APCHI=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+15 SET APCHI=$$TRIM(APCHI)
+16 IF $GET(APCHSGHR)
Begin DoDot:3
+17 SET X=$PIECE(APCHI,"|")_U_U_$PIECE(APCHI,"|",2)_U_$PIECE(APCHI,"|",3)
SET $PIECE(APCHSGHR,"|",APCHX)=X
End DoDot:3
QUIT
+18 IF 'APCHSANY
DO FIRST^APCHS11
IF $DATA(APCHSQIT)
QUIT
SET APCHSANY=1
+19 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+20 IF APCHSNPG
WRITE ?26,"LAST",?38,"NEXT",!!
SET APCHSCT=0
+21 IF APCHX=1
WRITE !
WRITE $PIECE(APCHI,"|"),?24,$PIECE(APCHI,"|",2),?36,$PIECE(APCHI,"|",3),!
+22 IF APCHI["VARICELLA"
SET X=$$PHCP^APCHS2(APCHSPAT)
IF X]""
Begin DoDot:3
+23 WRITE ?2,"Patient has a Hx of Chicken pox not yet entered as a contraindication"
+24 WRITE !?2,"in the Immunization Package.",!,?2,X,!
End DoDot:3
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
QUIT
+27 ; CHANGED HOW X SET PRIOR TO CALL TO ^%ZOSF("TEST") IHS/DWG 4/21/91
KILL W
IF $DATA(APCHSPAT)
IF $DATA(X)
SET APCHSSAV=X
SET X="AMCHPCC"
XECUTE ^%ZOSF("TEST")
IF $DATA(APCHSSAV)
SET X=APCHSSAV
KILL APCHSSAV
IF $TEST
DO ^AMCHPCC
IF 1
+28 IF '$TEST
QUIT
+29 IF $DATA(W)
IF W]""
SET APCHSDIS=W
SET APCHSDUE="MAY BE DUE NOW"
SET APCHSDAT=""
DO DISPLAY^APCHS11
+30 KILL APCHSDIS,APCHSDUE,APCHSDAT,APCHSTPZ,W
+31 QUIT
+32 ;
+33 ;
BI() ;EP- check to see if using new imm package or not 1/5/1999 IHS/CMI/LAB
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))<100:0,1:1)
+2 ;end new subrotuine CMI/TUCSON/LAB
TDADULT ;ENTRY POINT - immunization TETANUS DIPTHERIA (Td-ADULT)
+1 KILL APCHSTEX
+2 IF APCHSAGE<12
QUIT
+3 ;Q:'$D(^AUPNVIMM("AC",APCHSPAT))
+4 KILL APCHS
+5 SET (APCHSDAT,APCHSDUE)=""
+6 ;IHS/CMI/LAB - patch 3
SET APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST IMM "_$SELECT($$BI:9,1:"02"),"APCHS(")
+7 IF APCHSERR
GOTO TDADULTX
+8 ; *array APCHS(1)="DATE^SERIES^IMMUNIZATION^VIMM IEN;AUPNVIMM^VISIT IEN"
+9 KILL APCHSERR
+10 SET APCHSDIS="Td-ADULT"
+11 SET APCHSINT=10*365
+12 SET APCHSIVD=$SELECT($DATA(APCHS(1)):9999999-$PIECE($PIECE(APCHS(1),U,1),".",1),1:"")
+13 SET APCHSEXD=$SELECT($$BI^APCHS11C:$O(^AUTTIMM("C",9,0)),1:$ORDER(^AUTTIMM("C","02",0)))
SET APCHSDF1=9999999.14
+14 ; computes/print immunization due date
DO DFSURV^APCHS11
TDADULTX ;
+1 KILL APCHS,APCHSDF1,APCHSEXD,APCHSTEX
+2 QUIT
+3 ;
+4 ;
FLU ;
+1 KILL APCHSTEX
+2 SET (APCHSDAT,APCHSDUE)=""
+3 KILL APCHSRSK
+4 IF $DATA(^ATXAX("B","SURVEILLANCE PNEUMOCOCCAL RISK"))
SET APCHSURP=$ORDER(^ATXAX("B","SURVEILLANCE PNEUMOCOCCAL RISK",""))
IF $DATA(^ATXPAT(APCHSURP,11,APCHSPAT))
SET APCHSRSK=""
+5 SET %=$$FMDIFF^XLFDT(DT,$PIECE(^DPT(APCHSPAT,0),U,3),1)
+6 ;quit if patient is under 6 months old
IF %<180
QUIT
+7 IF (APCHSAGE<65)&('$DATA(APCHSRSK))
GOTO FLUX
+8 SET APCHSDIS="INFLUENZA"
+9 SET APCHSINT=365
+10 ;S APCHSFLX="INFLUENZA" ;IHS/CMI/LAB - commented out
+11 ;S APCHSFLX=$O(^AUTTIMM("B","INFLUENZA","")) ;IHS/CMI/LAB - commented out
+12 ;S:'APCHSFLX APCHSFLX=$O(^AUTTIMM("C",12,"")) ;IHS/CMI/LAB - commented out
+13 ;IHS/CMI/LAB - new imm package patch 3
SET APCHSFLX=$SELECT($$BI:$O(^AUTTIMM("C",88,"")),1:$ORDER(^AUTTIMM("C",12,"")))
+14 IF 'APCHSFLX
Begin DoDot:1
+15 SET (APCHSDAT,APCHSDUE)=""
+16 SET APCHSTEX(1)="Influenza immunization appears indicated,"
+17 SET APCHSTEX(2)=" but INFLUENZA cannot be located in the"
+18 SET APCHSTEX(3)=" immunization type file, so the patient's"
+19 SET APCHSTEX(4)=" history cannot be evaluated."
End DoDot:1
GOTO DSPLY
+20 SET APCHSIVD=$ORDER(^AUPNVIMM("AA",APCHSPAT,APCHSFLX,""))
+21 IF 'APCHSIVD
SET APCHSDUE="MAY BE DUE NOW"
SET APCHSDAT=""
GOTO DSPLY
GETDATE ;
+1 DO COMPARE^APCHS11
DO GETDATE^APCHS11
DSPLY ;
+1 SET APCHSEXD=$SELECT($$BI^APCHS11C:$O(^AUTTIMM("C",88,0)),1:$ORDER(^AUTTIMM("C",12,0)))
SET APCHSDF1=9999999.14
DO REFDF^APCHS11
+2 DO DISPLAY^APCHS11
FLUX ;
+1 KILL APCHSURP,APCHSRSK,APCHSFLX,APCHSTEX,APCHSEXD,APCHSDF1
+2 QUIT
+3 ;
+4 ;
TOBACCO ;ENTRY POINT - annual REVIEW OF TOBACCO USE
+1 ;IHS/CMI/LAB 12/16/97
IF APCHSAGE<13
QUIT
+2 ;
+3 SET APCHSCAT=$ORDER(^AUTTHF("B","TOBACCO",""))
+4 ; tobacco category does not exist
IF 'APCHSCAT
QUIT
+5 SET APCHSDIS="REVIEW OF TOBACCO USE"
+6 SET APCHSINT=365
+7 DO HFACTOR
TOBACCOX ;
+1 QUIT
+2 ;
+3 ;
ALCOHOL ;ENTRY POINT - annual REVIEW OF ALCOHOL USE
+1 ;IHS/CMI/LAB 12/16/97
IF APCHSAGE<13
QUIT
+2 ;
+3 SET APCHSCAT=$ORDER(^AUTTHF("B","ALCOHOL",""))
+4 ; alcohol/drug category does not exist
IF 'APCHSCAT
QUIT
+5 SET APCHSDIS="REVIEW OF ALCOHOL USE"
+6 SET APCHSINT=365
+7 DO HFACTOR
ALCOHOLX ;
+1 QUIT
+2 ;
HFACTOR ;EP called from TOBACCO and ALCOHOL sub-rtns
+1 ;IHS/CMI/LAB - modified this subroutine patch 3
+2 ;this had to be modified to get the last of each category
+3 ;it was getting the last of the first factor it found within the
+4 ;category
+5 SET APCHSHFD=0
+6 FOR
SET APCHSHFD=$ORDER(^AUTTHF("AC",APCHSCAT,APCHSHFD))
IF '+APCHSHFD
QUIT
Begin DoDot:1
+7 IF '$DATA(^AUPNVHF("AA",APCHSPAT,APCHSHFD))
QUIT
+8 SET APCHSIVD=$ORDER(^AUPNVHF("AA",APCHSPAT,APCHSHFD,""))
+9 IF 'APCHSIVD
QUIT
+10 SET APCHSONE(APCHSIVD)=""
+11 QUIT
End DoDot:1
+12 IF $DATA(APCHSONE)
Begin DoDot:1
+13 SET APCHSIVD=$ORDER(APCHSONE(""))
+14 DO COMPARE^APCHS11
+15 DO GETDATE^APCHS11
+16 ;S APCHSONE=1
+17 QUIT
End DoDot:1
+18 IF '$DATA(APCHSONE)
SET APCHSDUE="MAY BE DUE NOW"
SET APCHSDAT=""
+19 DO DISPLAY^APCHS11
HFACTORX ;
+1 KILL APCHSONE
+2 QUIT
+3 ;
+4 ;
PHYSCL ;ENTRY POINT - annual PHYSICAL EXAM
+1 IF '$DATA(^AUPNVPOV("AC",APCHSPAT))
QUIT
+2 KILL APCHS
+3 SET APCHSERR=$$START1^APCLDF(APCHSPAT_"^LAST DX [SURVEILLANCE PHYSICAL EXAM;","APCHS(")
+4 IF APCHSERR
GOTO PHYSCLX
+5 ; *array APCHS(1)="DATE^CODE^CODE^VPOV IEN;AUPNVPOV^VISIT IEN"
+6 KILL APCHSERR
+7 SET APCHSDIS="PHYSICAL EXAM"
+8 SET APCHSINT=365
+9 SET APCHSIVD=$SELECT($DATA(APCHS(1)):9999999-$PIECE($PIECE(APCHS(1),U,1),".",1),1:"")
+10 ; computes/print exam due date
DO DFSURV^APCHS11
PHYSCLX ;
+1 KILL APCHS
+2 QUIT
+3 ;
SIGMOID ;IHS/ANMC/LAB - added thisnew reminder per Dr. Murphy
+1 ;EVERY 5 YEARS AFTER AGE 50
+2 IF APCHSAGE<50
QUIT
+3 ;IHS/CMI/LAB - added for override
SET APCHLAST=""
SET APCHNEXT=""
KILL APCHSTEX
+4 ;IHS/ANMC/CLS 10/01/2002
WRITE !
+5 NEW %,%1,D
+6 KILL APCHSPRC
+7 ;cmi/anch/maw 8/27/2007 mods for code set versioning
+8 NEW APCHSVDT
+9 ;S %=0 F S %=$O(^AUPNVPRC("AC",APCHSPAT,%)) Q:%'=+% S %1=$P(^ICD0($P(^AUPNVPRC(%,0),U),0),U) D
+10 SET %=0
FOR
SET %=$ORDER(^AUPNVPRC("AC",APCHSPAT,%))
IF %'=+%
QUIT
SET APCHSVDT=$PIECE(+^AUPNVSIT($PIECE(^AUPNVPRC(%,0),U,3),0),".")
SET %1=$PIECE($$ICDOP^ICDEX($PIECE(^AUPNVPRC(%,0),U),APCHSVDT,,"I"),U,2)
Begin DoDot:1
+11 IF %1=48.23!(%1>45.20&(%1<45.26))
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(%,0),U,3),0),U),".")
SET APCHSPRC(9999999-D)=""
End DoDot:1
+12 ;S APCHSINT=365*5,APCHSDIS="SIGMOIDOSCOPY",APCHSIVD=$O(APCHSPRC("")) ;IHS/ANMC/CLS 02/25/01 IHS/CMI/LAB - replaced for override
+13 ;cmi/anch/maw 8/27/2007 end of mods
+14 ;IHS/CMI/LAB - added for override
SET APCHLAST=$ORDER(APCHSPRC(0))
IF APCHLAST]""
SET APCHLAST=9999999-APCHLAST
+15 ;IHS/CMI/LAB - added lines below for override
+16 SET APCHOVR=$$OVR^APCHSMU(APCHSPAT,APCHSITI)
+17 IF $PIECE(APCHOVR,U)>APCHLAST
Begin DoDot:1
+18 SET X=$$DATE^APCHSMU($PIECE(APCHOVR,U))_" (per "_$PIECE(APCHOVR,U,2)_")"
DO S(X)
SET X=$PIECE(APCHOVR,U,3)
DO S(X)
+19 DO SIGWT
+20 QUIT
End DoDot:1
QUIT
+21 ;IHS/ANMC/CLS 02/25/01
SET APCHSINT=365*5
SET APCHSDIS="COLORECTAL SCREENING"
SET APCHSIVD=$ORDER(APCHSPRC(""))
+22 IF 'APCHSIVD
SET APCHSDUE="MAY BE DUE NOW"
SET APCHSDAT=""
DO DISPLAY^APCHS11
XECUTE APCHSURX
QUIT
+23 DO GETDATE^APCHS11
DO COMPARE^APCHS11
DO DISPLAY^APCHS11
XECUTE APCHSURX
+24 QUIT
TRIM(X) ;EP
+1 ;---> TRIM OFF ANY LEADING SPACES.
+2 IF '$DATA(X)
QUIT ""
+3 NEW I,L
SET L=$LENGTH(X)
+4 FOR I=1:1
IF $EXTRACT(X,I)'=" "
QUIT
+5 QUIT $EXTRACT(X,I,L)
SIGWT ;
+1 DO WRITE^APCHSMU
+2 XECUTE APCHSURX
+3 QUIT
+4 ;
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
