APCHS11 ; IHS/CMI/LAB - PART 11 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**2,7**;MAY 14, 2009
;IHS/CMI/LAB - per task order added refusal check for exams,dm items
;
SURV ; ******************** SURVEILLANCE - HARD CODE *******
Q:'$D(^APCHSCTL(APCHSTYP,5,0))
S APCHSDOB=$P(^DPT(APCHSPAT,0),U,3)
S X1=DT,X2=APCHSDOB D ^%DTC S APCHSAGE=$$AGE^AUPNPAT(APCHSPAT)
S APCHSEX=$P(^DPT(APCHSPAT,0),U,2)
;
S (APCHSANY,APCHSITM)=0
K APCHSTEX
;
S APCHSURX="K APCHSTEX,APCHOVR,APCHMIN,D,APCHICAR,APCHLAST,APCHSRTP,APCHNEXT,APCHSBWR,X,C,%,T,Y,APCHNUMD,S,R,APCHTAXN,APCHSINT,APCHT,APCHREF,APCHSCRI,APCHTEST,APCHLSIG,APCHLCOL X APCHSURZ"
S APCHSURZ="K APCHLBE,APCHPBEG,N,APCHPNEU,APCHMMR,APCHY,APCHX,APCHLSIC,APCHLCOI,APCHLBEI"
;
F APCHSLP=0:0 S APCHSITM=$O(^APCHSCTL(APCHSTYP,5,APCHSITM)) Q:'APCHSITM!($D(APCHSQIT)) D
.S APCHSITI=$P(^APCHSCTL(APCHSTYP,5,APCHSITM,0),U,2)
.I $P(^APCHSURV($P(^APCHSCTL(APCHSTYP,5,APCHSITM,0),U,2),0),U,7)'="R" Q ;REMINDERS ONLY
.I $D(^APCHSURV($P(^APCHSCTL(APCHSTYP,5,APCHSITM,0),U,2),0)) S APCHSDO=$P(^(0),U,2) I APCHSDO]"" D @($P(APCHSDO,";")_U_$P(APCHSDO,";",2))
;
D EOJ
Q
;
TP ; ******************** BEST PRACTICE PROMPTS - HARD CODE *******
Q:'$D(^APCHSCTL(APCHSTYP,13,0))
S APCHSDOB=$P(^DPT(APCHSPAT,0),U,3)
S X1=DT,X2=APCHSDOB D ^%DTC S APCHSAGE=$$AGE^AUPNPAT(APCHSPAT)
S APCHSEX=$P(^DPT(APCHSPAT,0),U,2)
;
S (APCHSANY,APCHSITM)=0
K APCHSTEX
S APCHSURX="K APCHSTEX,APCHOVR,APCHICAR,APCHLAST,APCHSRTP,APCHNEXT,APCHSBWR,APCHCOLW,X,C,%,T,Y,APCHNUMD,S,R,APCHTAXN,APCHSINT,APCHT,APCHREF,APCHSCRI,APCHTEST,APCHLSIG,APCHLCOL,APCHLBE,APCHPBEG,N,APCHPNEU,APCHMMR,APCHY,APCHX,APCHLSIC"
;
F APCHSLP=0:0 S APCHSITM=$O(^APCHSCTL(APCHSTYP,13,APCHSITM)) Q:'APCHSITM!($D(APCHSQIT)) D
.S APCHSITI=$P(^APCHSCTL(APCHSTYP,13,APCHSITM,0),U,2)
.I $P(^APCHSURV($P(^APCHSCTL(APCHSTYP,13,APCHSITM,0),U,2),0),U,7)'="T" Q ;REMINDERS ONLY
.S APCHCOLW=48
.I $D(^APCHSURV($P(^APCHSCTL(APCHSTYP,13,APCHSITM,0),U,2),0)) S APCHSDO=$P(^(0),U,2) I APCHSDO]"" D @($P(APCHSDO,";")_U_$P(APCHSDO,";",2))
;
D EOJ
Q
URINE ;
Q:APCHSAGE'<13
K APCHSLDT
S APCHSLAB="URINALYSIS" D LABDFN D:APCHSLBD MULTLAB
S APCHSLAB="URINE GLUCOSE" D LABDFN D:APCHSLBD MULTLAB
Q:'APCHSLBD
S APCHSDIS="URINALYSIS"
S APCHSIVD=$O(APCHSLDT(""))
I 'APCHSIVD,APCHSAGE>5 S APCHSDUE="MAY BE DUE NOW",APCHSDAT="" D DISPLAY Q
I 'APCHSIVD S X1=APCHSDOB,X2=365*5 D C^%DTC S Y=X X APCHSCVD S APCHSDUE=Y,APCHSDAT="" D DISPLAY Q
D GETDATE S APCHSLST=APCHSDAT
D PASTAGE
I APCHSAGE<5,APCHSOLD'>3 S APCHSIVD=9999999-(APCHSDOB+50000) D GETDATE S APCHSDUE=APCHSDAT,APCHSDAT=APCHSLST D DISPLAY Q
D PASTAGE I APCHSOLD'>3 S APCHSDUE="MAY BE DUE NOW",APCHSDAT=APCHSLST D DISPLAY Q
Q
;
MULTLAB ;ENTRY POINT
;GET LAST VISIT DATE FROM AMONG TWO LAB TESTS
K APCHSDT
S APCHSDT=$O(^AUPNVLAB("AA",APCHSPAT,APCHSLBD,""))
I APCHSDT S APCHSLDT(APCHSDT)=""
Q
;
REGEXAM ;ENTRY POINT
;PELVIC, RECTAL, BREAST
D EXAMDFN Q:'APCHSEXD
S APCHSIVD=$O(^AUPNVXAM("AA",APCHSPAT,APCHSEXD,""))
I 'APCHSIVD S APCHSDUE="MAY BE DUE NOW",APCHSDAT="" D REFEXAM,DISPLAY Q
D GETDATE
I '$D(APCHSTEX) D COMPARE,REFEXAM,DISPLAY I 1
E D DISPLAY
Q
;
;
REGLAB ;ENTRY POINT
D LABDFN
Q:'APCHSLBD
S APCHSIVD=$O(^AUPNVLAB("AA",APCHSPAT,APCHSLBD,""))
I 'APCHSIVD S APCHSDUE="MAY BE DUE NOW",APCHSDAT="",APCHSEXD=$O(^LAB(60,"B",APCHSLAB,0)),APCHSDF1=60 D REFDF,DISPLAY G A
D GETDATE
S APCHSEXD=$O(^LAB(60,"B",APCHSLAB,0)),APCHSDF1=60
I '$D(APCHSTEX) D COMPARE D REFDF,DISPLAY I 1
E D REFDF,DISPLAY
A Q
;
DFSURV ;ENTRY POINT (SURVEILLANCES found by the Data Fetcher)
;DM FOOT, DM EYE, DM DENTAL, DM CHOLESTEROL, DM CREATININE
;DM TRIGLYCERIDES, PHYSICAL EXAMS
I 'APCHSIVD S APCHSDUE="MAY BE DUE NOW",APCHSDAT="" D REFDF,DISPLAY G DFSURVX
D GETDATE
I '$D(APCHSTEX) D COMPARE,REFDF,DISPLAY I 1
E D DISPLAY
DFSURVX ;
Q
;
;
COMPARE ;ENTRY POINT
S X1=9999999-$P(APCHSIVD,"."),X2=APCHSINT D C^%DTC S Y=X X APCHSCVD S (APCHSDUE,APCHSWD)=Y
S X2=9999999-$P(APCHSIVD,"."),X1=DT D ^%DTC I X>APCHSINT S APCHSDUE=$S('$D(APCHSDD):"MAY BE DUE NOW (WAS DUE "_APCHSWD_")",1:"MAY BE DUE NOW")
Q
;
GETDATE ;ENTRY POINT
S Y=-$P(APCHSIVD,".")+9999999 X APCHSCVD S APCHSDAT=Y
Q
;
PASTAGE ;ENTRY POINT;GETS AGE AT TIME OF LAST PROCEDURE OR EXAM, ETC
S X1=9999999-$P(APCHSIVD,"."),X2=APCHSDOB D ^%DTC S APCHSOLD=$J(X/365.25,1,2)
Q
;
EXAMDFN ;ENTRY POINT
S APCHSEXD=$O(^AUTTEXAM("C",APCHSEXN,""))
Q
;
LABDFN ;ENTRY POINT
S APCHSLBD=$O(^LAB(60,"B",APCHSLAB,""))
Q
;
DISPLAY ;ENTRY POINT
I 'APCHSANY D FIRST Q:$D(APCHSQIT) S APCHSANY=1
X APCHSCKP Q:$D(APCHSQIT)
I APCHSNPG W ?25,"LAST",?38,"NEXT",!! S APCHSCT=0
W APCHSDIS,?23,APCHSDAT
I $D(APCHSTEX) W ?36,APCHSTEX(1) F APCHSL=2:1 Q:'$D(APCHSTEX(APCHSL)) W !,?36,APCHSTEX(APCHSL)
E W ?36,APCHSDUE
W @$S('$D(APCHSTEX):"!",1:"!")
S APCHSCT=APCHSCT+1
I '(APCHSCT#4) X APCHSCKP Q:$D(APCHSQIT) W:'APCHSNPG !
K APCHSTEX Q
;
FIRST ;EP
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
W ?25,"LAST",?38,"NEXT",!!
S APCHSCT=0
Q
;
REFDF ;EP dm item declined?
I '$G(APCHSDF1) Q
I $G(APCHSDUE)'["DUE" Q
I $G(APCHSTAX)]"" D REFDFM Q
I '$G(APCHSEXD) Q
NEW X S X=$O(^AUPNPREF("AA",APCHSPAT,APCHSDF1,APCHSEXD,0))
I 'X Q ;none of this exam was declined
N APCHS1,APCHS2 S (APCHS1,APCHS2)=0 F S APCHS1=$O(APCHSTEX(APCHS1)) Q:APCHS1'=+APCHS1 S APCHS2=APCHS1
I $D(APCHSTEX) S APCHS2=APCHS2+1,APCHSTEX(APCHS2)="**NOTE** Patient declined a "_APCHSDIS,APCHSTEX(3)=" on "_$$FMTE^XLFDT((9999999-X)) Q
I '$D(APCHSTEX) S APCHS2=APCHS2+1,APCHSTEX(APCHS2)=APCHSDUE,APCHS2=APCHS2+1,APCHSTEX(APCHS2)="**NOTE** Patient declined a "_APCHSDIS,APCHSTEX(3)=" on "_$$FMTE^XLFDT((9999999-X))
Q
REFDFM ;taxonomy check for dm item
NEW G
S G=0,APCHSEXD=0 F S APCHSEXD=$O(^ATXLAB(APCHSTAX,21,"B",APCHSEXD)) Q:APCHSEXD'=+APCHSEXD!(G) D
.NEW X S X=$O(^AUPNPREF("AA",APCHSPAT,APCHSDF1,APCHSEXD,0))
.I 'X Q ;none of this exam was declined
.S G=1 N APCHS1,APCHS2 S (APCHS1,APCHS2)=0 F S APCHS1=$O(APCHSTEX(APCHS1)) Q:APCHS1'=+APCHS1 S APCHS2=APCHS1
.I $D(APCHSTEX) S APCHS2=APCHS2+1,APCHSTEX(APCHS2)="**NOTE** Patient declined a "_APCHSDIS,APCHSTEX(3)=" on "_$$FMTE^XLFDT((9999999-X)) Q
.I '$D(APCHSTEX) S APCHS2=APCHS2+1,APCHSTEX(APCHS2)=APCHSDUE,APCHS2=APCHS2+1,APCHSTEX(APCHS2)="**NOTE** Patient declined a "_APCHSDIS,APCHSTEX(3)=" on "_$$FMTE^XLFDT((9999999-X))
Q
REFEXAM ; did this patient refuse this exam
I '$G(APCHSEXD) Q
Q:$G(APCHSDUE)'["MAY BE DUE"
NEW X S X=$O(^AUPNPREF("AA",APCHSPAT,9999999.15,APCHSEXD,0))
I 'X Q ;none of this exam was declined
K APCHSTEX S APCHSTEX(1)=APCHSDUE,APCHSTEX(2)="**NOTE** Patient declined a "_APCHSDIS,APCHSTEX(3)=" on "_$$FMTE^XLFDT((9999999-X))
Q
EOJ ;
K APCHSEXM,APCHSEXD,APCHSIVD,APCHSDUE,APCHSNTE,APCHSDOB,APCHSAGE,APCHSINT,APCHSWD,APCHSPRC,APCHSTP,APCHSDF
K APCHSCT,APCHSBP,APCHSITM,APCHSDO,APCHSDA,APCHSER,APCHSINM,APCHSLP
K X1,X2,APCHSLAB,APCHSYRY,APCHSL
K APCHSOLD,APCHSIVB,APCHSIVA,APCHSLST,APCHSANY,APCHSDAT,APCHSDIS,APCHSEX,APCHSEXN,APCHSLBD,APCHSKDT,APCHSKN,APCHSKND,APCHSLDT,APCHSDT
K APCHSIM,APCHSIMD,APCHSKD,APCHSMSC,APCHSMSD,APCHSURD,APCHSLAB
K APCHSMDT,APCHSMAM,APCHSDD,X,Y
K APCHS,APCHDMPT,APCHSCAT,APCHSONE,APCHSHFD
Q
;
APCHS11 ; IHS/CMI/LAB - PART 11 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**2,7**;MAY 14, 2009
+2 ;IHS/CMI/LAB - per task order added refusal check for exams,dm items
+3 ;
SURV ; ******************** SURVEILLANCE - HARD CODE *******
+1 IF '$DATA(^APCHSCTL(APCHSTYP,5,0))
QUIT
+2 SET APCHSDOB=$PIECE(^DPT(APCHSPAT,0),U,3)
+3 SET X1=DT
SET X2=APCHSDOB
DO ^%DTC
SET APCHSAGE=$$AGE^AUPNPAT(APCHSPAT)
+4 SET APCHSEX=$PIECE(^DPT(APCHSPAT,0),U,2)
+5 ;
+6 SET (APCHSANY,APCHSITM)=0
+7 KILL APCHSTEX
+8 ;
+9 SET APCHSURX="K APCHSTEX,APCHOVR,APCHMIN,D,APCHICAR,APCHLAST,APCHSRTP,APCHNEXT,APCHSBWR,X,C,%,T,Y,APCHNUMD,S,R,APCHTAXN,APCHSINT,APCHT,APCHREF,APCHSCRI,APCHTEST,APCHLSIG,APCHLCOL X APCHSURZ"
+10 SET APCHSURZ="K APCHLBE,APCHPBEG,N,APCHPNEU,APCHMMR,APCHY,APCHX,APCHLSIC,APCHLCOI,APCHLBEI"
+11 ;
+12 FOR APCHSLP=0:0
SET APCHSITM=$ORDER(^APCHSCTL(APCHSTYP,5,APCHSITM))
IF 'APCHSITM!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+13 SET APCHSITI=$PIECE(^APCHSCTL(APCHSTYP,5,APCHSITM,0),U,2)
+14 ;REMINDERS ONLY
IF $PIECE(^APCHSURV($PIECE(^APCHSCTL(APCHSTYP,5,APCHSITM,0),U,2),0),U,7)'="R"
QUIT
+15 IF $DATA(^APCHSURV($PIECE(^APCHSCTL(APCHSTYP,5,APCHSITM,0),U,2),0))
SET APCHSDO=$PIECE(^(0),U,2)
IF APCHSDO]""
DO @($PIECE(APCHSDO,";")_U_$PIECE(APCHSDO,";",2))
End DoDot:1
+16 ;
+17 DO EOJ
+18 QUIT
+19 ;
TP ; ******************** BEST PRACTICE PROMPTS - HARD CODE *******
+1 IF '$DATA(^APCHSCTL(APCHSTYP,13,0))
QUIT
+2 SET APCHSDOB=$PIECE(^DPT(APCHSPAT,0),U,3)
+3 SET X1=DT
SET X2=APCHSDOB
DO ^%DTC
SET APCHSAGE=$$AGE^AUPNPAT(APCHSPAT)
+4 SET APCHSEX=$PIECE(^DPT(APCHSPAT,0),U,2)
+5 ;
+6 SET (APCHSANY,APCHSITM)=0
+7 KILL APCHSTEX
+8 SET APCHSURX="K APCHSTEX,APCHOVR,APCHICAR,APCHLAST,APCHSRTP,APCHNEXT,APCHSBWR,APCHCOLW,X,C,%,T,Y,APCHNUMD,S,R,APCHTAXN,APCHSINT,APCHT,APCHREF,APCHSCRI,APCHTEST,APCHLSIG,APCHLCOL,APCHLBE,APCHPBEG,N,APCHPNEU,APCHMMR,APCHY,APCHX,APCHLSIC"
+9 ;
+10 FOR APCHSLP=0:0
SET APCHSITM=$ORDER(^APCHSCTL(APCHSTYP,13,APCHSITM))
IF 'APCHSITM!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+11 SET APCHSITI=$PIECE(^APCHSCTL(APCHSTYP,13,APCHSITM,0),U,2)
+12 ;REMINDERS ONLY
IF $PIECE(^APCHSURV($PIECE(^APCHSCTL(APCHSTYP,13,APCHSITM,0),U,2),0),U,7)'="T"
QUIT
+13 SET APCHCOLW=48
+14 IF $DATA(^APCHSURV($PIECE(^APCHSCTL(APCHSTYP,13,APCHSITM,0),U,2),0))
SET APCHSDO=$PIECE(^(0),U,2)
IF APCHSDO]""
DO @($PIECE(APCHSDO,";")_U_$PIECE(APCHSDO,";",2))
End DoDot:1
+15 ;
+16 DO EOJ
+17 QUIT
URINE ;
+1 IF APCHSAGE'<13
QUIT
+2 KILL APCHSLDT
+3 SET APCHSLAB="URINALYSIS"
DO LABDFN
IF APCHSLBD
DO MULTLAB
+4 SET APCHSLAB="URINE GLUCOSE"
DO LABDFN
IF APCHSLBD
DO MULTLAB
+5 IF 'APCHSLBD
QUIT
+6 SET APCHSDIS="URINALYSIS"
+7 SET APCHSIVD=$ORDER(APCHSLDT(""))
+8 IF 'APCHSIVD
IF APCHSAGE>5
SET APCHSDUE="MAY BE DUE NOW"
SET APCHSDAT=""
DO DISPLAY
QUIT
+9 IF 'APCHSIVD
SET X1=APCHSDOB
SET X2=365*5
DO C^%DTC
SET Y=X
XECUTE APCHSCVD
SET APCHSDUE=Y
SET APCHSDAT=""
DO DISPLAY
QUIT
+10 DO GETDATE
SET APCHSLST=APCHSDAT
+11 DO PASTAGE
+12 IF APCHSAGE<5
IF APCHSOLD'>3
SET APCHSIVD=9999999-(APCHSDOB+50000)
DO GETDATE
SET APCHSDUE=APCHSDAT
SET APCHSDAT=APCHSLST
DO DISPLAY
QUIT
+13 DO PASTAGE
IF APCHSOLD'>3
SET APCHSDUE="MAY BE DUE NOW"
SET APCHSDAT=APCHSLST
DO DISPLAY
QUIT
+14 QUIT
+15 ;
MULTLAB ;ENTRY POINT
+1 ;GET LAST VISIT DATE FROM AMONG TWO LAB TESTS
+2 KILL APCHSDT
+3 SET APCHSDT=$ORDER(^AUPNVLAB("AA",APCHSPAT,APCHSLBD,""))
+4 IF APCHSDT
SET APCHSLDT(APCHSDT)=""
+5 QUIT
+6 ;
REGEXAM ;ENTRY POINT
+1 ;PELVIC, RECTAL, BREAST
+2 DO EXAMDFN
IF 'APCHSEXD
QUIT
+3 SET APCHSIVD=$ORDER(^AUPNVXAM("AA",APCHSPAT,APCHSEXD,""))
+4 IF 'APCHSIVD
SET APCHSDUE="MAY BE DUE NOW"
SET APCHSDAT=""
DO REFEXAM
DO DISPLAY
QUIT
+5 DO GETDATE
+6 IF '$DATA(APCHSTEX)
DO COMPARE
DO REFEXAM
DO DISPLAY
IF 1
+7 IF '$TEST
DO DISPLAY
+8 QUIT
+9 ;
+10 ;
REGLAB ;ENTRY POINT
+1 DO LABDFN
+2 IF 'APCHSLBD
QUIT
+3 SET APCHSIVD=$ORDER(^AUPNVLAB("AA",APCHSPAT,APCHSLBD,""))
+4 IF 'APCHSIVD
SET APCHSDUE="MAY BE DUE NOW"
SET APCHSDAT=""
SET APCHSEXD=$ORDER(^LAB(60,"B",APCHSLAB,0))
SET APCHSDF1=60
DO REFDF
DO DISPLAY
GOTO A
+5 DO GETDATE
+6 SET APCHSEXD=$ORDER(^LAB(60,"B",APCHSLAB,0))
SET APCHSDF1=60
+7 IF '$DATA(APCHSTEX)
DO COMPARE
DO REFDF
DO DISPLAY
IF 1
+8 IF '$TEST
DO REFDF
DO DISPLAY
A QUIT
+1 ;
DFSURV ;ENTRY POINT (SURVEILLANCES found by the Data Fetcher)
+1 ;DM FOOT, DM EYE, DM DENTAL, DM CHOLESTEROL, DM CREATININE
+2 ;DM TRIGLYCERIDES, PHYSICAL EXAMS
+3 IF 'APCHSIVD
SET APCHSDUE="MAY BE DUE NOW"
SET APCHSDAT=""
DO REFDF
DO DISPLAY
GOTO DFSURVX
+4 DO GETDATE
+5 IF '$DATA(APCHSTEX)
DO COMPARE
DO REFDF
DO DISPLAY
IF 1
+6 IF '$TEST
DO DISPLAY
DFSURVX ;
+1 QUIT
+2 ;
+3 ;
COMPARE ;ENTRY POINT
+1 SET X1=9999999-$PIECE(APCHSIVD,".")
SET X2=APCHSINT
DO C^%DTC
SET Y=X
XECUTE APCHSCVD
SET (APCHSDUE,APCHSWD)=Y
+2 SET X2=9999999-$PIECE(APCHSIVD,".")
SET X1=DT
DO ^%DTC
IF X>APCHSINT
SET APCHSDUE=$SELECT('$DATA(APCHSDD):"MAY BE DUE NOW (WAS DUE "_APCHSWD_")",1:"MAY BE DUE NOW")
+3 QUIT
+4 ;
GETDATE ;ENTRY POINT
+1 SET Y=-$PIECE(APCHSIVD,".")+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
+2 QUIT
+3 ;
PASTAGE ;ENTRY POINT;GETS AGE AT TIME OF LAST PROCEDURE OR EXAM, ETC
+1 SET X1=9999999-$PIECE(APCHSIVD,".")
SET X2=APCHSDOB
DO ^%DTC
SET APCHSOLD=$JUSTIFY(X/365.25,1,2)
+2 QUIT
+3 ;
EXAMDFN ;ENTRY POINT
+1 SET APCHSEXD=$ORDER(^AUTTEXAM("C",APCHSEXN,""))
+2 QUIT
+3 ;
LABDFN ;ENTRY POINT
+1 SET APCHSLBD=$ORDER(^LAB(60,"B",APCHSLAB,""))
+2 QUIT
+3 ;
DISPLAY ;ENTRY POINT
+1 IF 'APCHSANY
DO FIRST
IF $DATA(APCHSQIT)
QUIT
SET APCHSANY=1
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+3 IF APCHSNPG
WRITE ?25,"LAST",?38,"NEXT",!!
SET APCHSCT=0
+4 WRITE APCHSDIS,?23,APCHSDAT
+5 IF $DATA(APCHSTEX)
WRITE ?36,APCHSTEX(1)
FOR APCHSL=2:1
IF '$DATA(APCHSTEX(APCHSL))
QUIT
WRITE !,?36,APCHSTEX(APCHSL)
+6 IF '$TEST
WRITE ?36,APCHSDUE
+7 WRITE @$SELECT('$DATA(APCHSTEX):"!",1:"!")
+8 SET APCHSCT=APCHSCT+1
+9 IF '(APCHSCT#4)
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
WRITE !
+10 KILL APCHSTEX
QUIT
+11 ;
FIRST ;EP
+1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+2 WRITE ?25,"LAST",?38,"NEXT",!!
+3 SET APCHSCT=0
+4 QUIT
+5 ;
REFDF ;EP dm item declined?
+1 IF '$GET(APCHSDF1)
QUIT
+2 IF $GET(APCHSDUE)'["DUE"
QUIT
+3 IF $GET(APCHSTAX)]""
DO REFDFM
QUIT
+4 IF '$GET(APCHSEXD)
QUIT
+5 NEW X
SET X=$ORDER(^AUPNPREF("AA",APCHSPAT,APCHSDF1,APCHSEXD,0))
+6 ;none of this exam was declined
IF 'X
QUIT
+7 NEW APCHS1,APCHS2
SET (APCHS1,APCHS2)=0
FOR
SET APCHS1=$ORDER(APCHSTEX(APCHS1))
IF APCHS1'=+APCHS1
QUIT
SET APCHS2=APCHS1
+8 IF $DATA(APCHSTEX)
SET APCHS2=APCHS2+1
SET APCHSTEX(APCHS2)="**NOTE** Patient declined a "_APCHSDIS
SET APCHSTEX(3)=" on "_$$FMTE^XLFDT((9999999-X))
QUIT
+9 IF '$DATA(APCHSTEX)
SET APCHS2=APCHS2+1
SET APCHSTEX(APCHS2)=APCHSDUE
SET APCHS2=APCHS2+1
SET APCHSTEX(APCHS2)="**NOTE** Patient declined a "_APCHSDIS
SET APCHSTEX(3)=" on "_$$FMTE^XLFDT((9999999-X))
+10 QUIT
REFDFM ;taxonomy check for dm item
+1 NEW G
+2 SET G=0
SET APCHSEXD=0
FOR
SET APCHSEXD=$ORDER(^ATXLAB(APCHSTAX,21,"B",APCHSEXD))
IF APCHSEXD'=+APCHSEXD!(G)
QUIT
Begin DoDot:1
+3 NEW X
SET X=$ORDER(^AUPNPREF("AA",APCHSPAT,APCHSDF1,APCHSEXD,0))
+4 ;none of this exam was declined
IF 'X
QUIT
+5 SET G=1
NEW APCHS1,APCHS2
SET (APCHS1,APCHS2)=0
FOR
SET APCHS1=$ORDER(APCHSTEX(APCHS1))
IF APCHS1'=+APCHS1
QUIT
SET APCHS2=APCHS1
+6 IF $DATA(APCHSTEX)
SET APCHS2=APCHS2+1
SET APCHSTEX(APCHS2)="**NOTE** Patient declined a "_APCHSDIS
SET APCHSTEX(3)=" on "_$$FMTE^XLFDT((9999999-X))
QUIT
+7 IF '$DATA(APCHSTEX)
SET APCHS2=APCHS2+1
SET APCHSTEX(APCHS2)=APCHSDUE
SET APCHS2=APCHS2+1
SET APCHSTEX(APCHS2)="**NOTE** Patient declined a "_APCHSDIS
SET APCHSTEX(3)=" on "_$$FMTE^XLFDT((9999999-X))
End DoDot:1
+8 QUIT
REFEXAM ; did this patient refuse this exam
+1 IF '$GET(APCHSEXD)
QUIT
+2 IF $GET(APCHSDUE)'["MAY BE DUE"
QUIT
+3 NEW X
SET X=$ORDER(^AUPNPREF("AA",APCHSPAT,9999999.15,APCHSEXD,0))
+4 ;none of this exam was declined
IF 'X
QUIT
+5 KILL APCHSTEX
SET APCHSTEX(1)=APCHSDUE
SET APCHSTEX(2)="**NOTE** Patient declined a "_APCHSDIS
SET APCHSTEX(3)=" on "_$$FMTE^XLFDT((9999999-X))
+6 QUIT
EOJ ;
+1 KILL APCHSEXM,APCHSEXD,APCHSIVD,APCHSDUE,APCHSNTE,APCHSDOB,APCHSAGE,APCHSINT,APCHSWD,APCHSPRC,APCHSTP,APCHSDF
+2 KILL APCHSCT,APCHSBP,APCHSITM,APCHSDO,APCHSDA,APCHSER,APCHSINM,APCHSLP
+3 KILL X1,X2,APCHSLAB,APCHSYRY,APCHSL
+4 KILL APCHSOLD,APCHSIVB,APCHSIVA,APCHSLST,APCHSANY,APCHSDAT,APCHSDIS,APCHSEX,APCHSEXN,APCHSLBD,APCHSKDT,APCHSKN,APCHSKND,APCHSLDT,APCHSDT
+5 KILL APCHSIM,APCHSIMD,APCHSKD,APCHSMSC,APCHSMSD,APCHSURD,APCHSLAB
+6 KILL APCHSMDT,APCHSMAM,APCHSDD,X,Y
+7 KILL APCHS,APCHDMPT,APCHSCAT,APCHSONE,APCHSHFD
+8 QUIT
+9 ;
