Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCHS11

APCHS11.m

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