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

APCHS11C.m

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