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

BHSFLOW.m

Go to the documentation of this file. 
  1. BHSFLOW ;IHS/CIA/MGH - Health Summary for Flowsheets ;02-Jan-2014 14:31;DU
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**2,9**;March 17, 2006;Build 16
  1.  ;===================================================================
  1.  ; Taken from APCHS12
  1.  ; IHS/TUCSON/LAB - PART 12 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
  1.  ;;2.0;IHS RPMS/PCC Health Summary;**5,8,9**;JUN 24, 1997
  1.  ;Modified to be used in VA health summary for flowsheet component of health summary
  1.  ;======================================================================
  1. FLOW ; ********** FLOWSHEET PRODUCTION **********
  1.  ; <SETUP>
  1.  N BHSPAT,APCHSPAT
  1.  S (BHSPAT,APCHSPAT)=DFN
  1.  Q:'$D(^AUPNVSIT("AA",BHSPAT))
  1.  S BHSFNM=0
  1.  S BHSND2=GMTSNDM
  1.  Q:$O(GMTSEG(GMTSEGN,9001020,0))'>0
  1.  F BHSFOR=0:0 S BHSFOR=$O(GMTSEG(GMTSEGN,9001020,BHSFOR)) Q:'BHSFOR  S GMTSNDM=BHSND2 D FLOWOUT Q:$D(GMTSQIT)
  1. FLOWX K BHSFOR,BHSND2,BHSDUS,BHSFCN,BHSIVD,BHSTB,BHSDB,BHSI,BHST,BHSW,BHSFDF,BHSAS,BHSVDF,BHSN,BHSIT,BHSCLN
  1.  K BHSDAT,BHSIDF,BHSITP,BHSJ,BHSL,BHSMXL,BHSTTL,BHSVGL,BHSX,BHSXT,BHSII,BHSNGL,BHSXS,BHSFXF
  1.  K BHSFOK,BHSPI,BHSCI,BHSC1,BHSC2,BHSCM,BHSFNM,BHSP,BHSQ,APCHSNVN,APCHSNYR,APCHSBD,APCHSFDF
  1.  Q
  1. FLOWOUT ; <DISPLAY>
  1.  S BHSFDF=$G(GMTSEG(GMTSEGN,9001020,BHSFOR))
  1.  D FLOWCHK Q:'BHSFOK
  1.  S BHSFNM=BHSFNM+1 I BHSFNM=1
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)   ; VA health summary routine
  1.  S BHSFCN=$P(^APCHSFLC(BHSFDF,0),U,1)
  1.  D FLOWTB
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  D FLOWHD
  1.  S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVSIT("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM)  D FLOWBD Q:$D(GMTSQIT)  I BHSDUS S GMTSNDM=GMTSNDM-1 Q:GMTSNDM=0
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I 'GMTSNPG S BHSP="",$P(BHSP,"-",BHSMXL+9)="" W ?2,BHSP,!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I 'GMTSNPG W !
  1.  Q
  1. FLOWCHK ; <SCREEN>
  1.  I '$O(^APCHSFLC(BHSFDF,2,0)) S BHSFOK=1 Q
  1.  S BHSFOK=0
  1.  ;Q:'$O(^AUPNPROB("AC",BHSPAT,0))
  1.  F BHSPI=0:0 S BHSPI=$O(^AUPNPROB("AC",BHSPAT,BHSPI)) Q:'BHSPI  D FLOWCP Q:BHSFOK
  1.  Q:BHSFOK  ;found on Problem list
  1. PVCH ;IHS/CMI/LAB - now check for dx in past year per Bill and Charlton by pcp
  1.  N X,%,V,Y,D,E
  1.  K APCHY,APCHV,^TMP($J,"ALL VISITS")
  1.  S APCHSNVN=$S($P($G(^APCHSITE(DUZ(2),12,BHSFDF,0)),U,2):$P($G(^APCHSITE(DUZ(2),12,BHSFDF,0)),U,2),1:1)
  1.  S APCHSNYR=$S($P($G(^APCHSITE(DUZ(2),12,BHSFDF,0)),U,3):$P($G(^APCHSITE(DUZ(2),12,BHSFDF,0)),U,3),1:1)
  1.  S APCHSNYR=APCHSNYR*365
  1.  S APCHSBD=$$FMADD^XLFDT(DT,-(APCHSNYR))
  1.  S APCHY="^TMP($J,""ALL VISITS"",",%=BHSPAT_"^ALL VISITS;DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(DT,-365))_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,APCHY)
  1.  I '$D(^TMP($J,"ALL VISITS",1)) Q
  1.  S X=0 F  S X=$O(^TMP($J,"ALL VISITS",X)) Q:X'=+X!(BHSFOK)  S V=$P(^TMP($J,"ALL VISITS",X),U,5) D
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:"DAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .Q:'$D(^AUPNVPRV("AD",V))
  1.  .Q:'$D(^AUPNVPOV("AD",V))
  1.  .;code set versioning changes
  1.  .;S (D,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D)  S BHSCM=$P($G(^AUPNVPOV(Y,0)),U) I BHSCM S BHSCM=$P($G(^ICD9(BHSCM,0)),U) I BHSCM]"" D CHKCODE
  1.  .N APCHSVDT
  1.  .S APCHSVDT=$P(+V,".")
  1.  .S (D,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D)  S BHSCM=$P($G(^AUPNVPOV(Y,0)),U) I BHSCM S BHSCM=$P($$ICDDX^ICDEX(BHSCM,APCHSVDT),U,2) I BHSCM]"" D CHKCODE
  1.  .Q:'D
  1.  .S Y=$$PRIMPROV^APCLV(V,"F")
  1.  .Q:'Y
  1.  .Q:$P($G(^DIC(7,Y,9999999)),U,3)'="Y"
  1.  .S BHSFOK=1
  1.  .Q
  1.  K ^TMP($J,"ALL VISITS"),APCHV,APCHY
  1.  Q
  1. FLOWCP ;
  1.  S BHSP=^AUPNPROB(BHSPI,0) Q:$P(BHSP,U,12)'="A"
  1.  ;S BHSCM=$P(^ICD9(+$P(BHSP,U,1),0),U,1)
  1.  S BHSCM=$P($$ICDDX^ICDEX(+$P(BHSP,U,1),0),U,2) ;code set versioning
  1.  F BHSCI=0:0 S BHSCI=$O(^APCHSFLC(BHSFDF,2,BHSCI)) Q:'BHSCI  D FLOWCR Q:BHSFOK
  1.  Q
  1. FLOWCR ;
  1.  S BHSC1=$P(^APCHSFLC(BHSFDF,2,BHSCI,0),U,1)
  1.  I BHSC1["-" S BHSC2=$P(BHSC1,"-",2),BHSC1=$P(BHSC1,"-",1)
  1.  E  S BHSC2=BHSC1
  1.  S BHSC1=BHSC1_" ",BHSC2=BHSC2_" "
  1.  I BHSC1'](BHSCM_" "),(BHSCM_" ")']BHSC2 S BHSFOK=1
  1.  ;I BHSC1']BHSCM,BHSCM']BHSC2 S BHSFOK=1
  1.  Q
  1. CHKCODE ;
  1.  F BHSCI=0:0 S BHSCI=$O(^APCHSFLC(BHSFDF,2,BHSCI)) Q:'BHSCI  D CHKCODE1 Q:D
  1.  Q
  1. CHKCODE1 ;
  1.  S D=0
  1.  S BHSC1=$P(^APCHSFLC(BHSFDF,2,BHSCI,0),U,1)
  1.  I BHSC1["-" S BHSC2=$P(BHSC1,"-",2),BHSC1=$P(BHSC1,"-",1)
  1.  E  S BHSC2=BHSC1
  1.  S BHSC1=BHSC1_" ",BHSC2=BHSC2_" "
  1.  I BHSC1'](BHSCM_" "),(BHSCM_" ")']BHSC2 S D=1
  1.  Q
  1. FLOWCKP ;ENTRY POINT
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  Q:'GMTSNPG
  1. FLOWHD ;ENTRY POINT
  1.  ; DISPLAY HEADER
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  W BHSFCN,!
  1.  I $O(^APCHSFLC(BHSFDF,3,0)) W ?2,"Clinics limited to:"
  1.  S X=0 F  S X=$O(^APCHSFLC(BHSFDF,3,X)) Q:'X  D CKP^GMTSUP  G:GMTSNPG FLOWHD W ?22,$P(^DIC(40.7,X,0),U),!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  G:GMTSNPG FLOWHD
  1.  F BHSII=0:0 S BHSII=$O(BHSTB(BHSII)) Q:'BHSII  W ?14+BHSTB(BHSII),BHSTB(BHSII,"L")
  1.  W !
  1.  Q
  1. FLOWTB ; BUILD TAB TABLE
  1.  K BHSTB
  1.  S BHST=1,BHSMXL=0
  1.  F BHSI=0:0 S BHSI=$O(^APCHSFLC(BHSFDF,1,BHSI)) Q:'BHSI  D FLOWTB2
  1.  Q
  1. FLOWTB2 S BHSW=0
  1.  Q:'($D(^APCHSFLC(BHSFDF,1,BHSI,0))#2)  S BHSN=^(0)
  1.  S BHSTTL=$P(BHSN,U,3) S BHSP=$L(BHSTTL) S:BHSP>BHSW BHSW=BHSP
  1.  S BHSP=$P(BHSN,U,4) S:+BHSP>BHSW BHSW=BHSP
  1.  S:BHSW=0 BHSW=10
  1.  S BHSTB(BHSI)=BHST_"^"_BHSW,BHSTB(BHSI,"L")=BHSTTL
  1.  S BHSMXL=BHSMXL+BHSW+2
  1.  S BHST=BHST+BHSW+2
  1.  Q
  1. FLOWBD ; BUILD AND DISPLAY DATA TABLE (FOR ONE DATE)
  1.  K BHSDB
  1.  S BHSDUS=0
  1.  F BHSVDF=0:0 S BHSVDF=$O(^AUPNVSIT("AA",BHSPAT,BHSIVD,BHSVDF)) Q:'BHSVDF  D FLOWB
  1.  D:$D(BHSDB) FLOWD^BHSFLOA
  1.  Q
  1. FLOWB S BHSCLN=$P(^AUPNVSIT(BHSVDF,0),U,8)
  1.  I BHSCLN,$O(^APCHSFLC(BHSFDF,3,0)),'$D(^(BHSCLN)) Q
  1.  S BHSDUS=1
  1.  F BHSIDF=0:0 S BHSIDF=$O(^APCHSFLC(BHSFDF,1,BHSIDF)) Q:'BHSIDF  S BHSJ=0 D FLOWB2 Q:$D(GMTSQIT)
  1.  Q
  1. FLOWB2 S BHSN=^APCHSFLC(BHSFDF,1,BHSIDF,0)
  1.  S BHSIT=$P(BHSN,U,2)
  1.  S BHSFXF=$G(^APCHSFLC(BHSFDF,1,BHSIDF,1))
  1.  S BHSX=^APCHSFLI(BHSIT,1)
  1.  S BHSXT=^APCHSFLI(BHSIT,2)
  1.  S BHSP=$P(^APCHSFLI(BHSIT,0),U,3),BHSVGL=^DIC(BHSP,0,"GL")_"""AD"",BHSVDF)"
  1.  S BHSAS=$O(^APCHSFLC(BHSFDF,1,BHSIDF,2,0)),BHSNGL=BHSAS&'$O(^(BHSAS)) D FLOWBA:'BHSAS,FLOWBS:BHSAS
  1.  Q
  1. FLOWBS ; ADD SPECIFIED ITEMS
  1.  N DA
  1.  F DA=0:0 S DA=$O(@BHSVGL@(DA)) Q:'DA  D FLOWBS2
  1.  Q
  1. FLOWBS2 ;
  1.  N I
  1.  X BHSXT
  1.  S BHSITP=X
  1.  F I=0:0 S I=$O(^APCHSFLC(BHSFDF,1,BHSIDF,2,I)) Q:'I  I +$P(^APCHSFLC(BHSFDF,1,BHSIDF,2,I,0),U,1)=BHSITP D FLOWADD Q
  1.  Q
  1. FLOWBA ; ADD ALL (NO ITEMS SPECIFIED)
  1.  N DA
  1.  F DA=0:0 S DA=$O(@BHSVGL@(DA)) Q:'DA  D FLOWADD
  1.  Q
  1. FLOWADD ; ADD VALUE FROM SELECTED FILE/DFN
  1.  N I
  1.  S BHSL=$P(BHSTB(BHSIDF),U,2)
  1.  X BHSX
  1. FLOWS I $L(X),$E(X,$L(X))=" " S X=$E(X,1,$L(X)-1) G FLOWS
  1.  I BHSFXF]"",$P(X,"=",2)]"" S BHSXS=$P(X,"="),X=$P(X,"=",2) X BHSFXF S X=BHSXS_"="_X
  1.  S:$E(X,$L(X))="=" X="n/r" ;per Gary Lawless do not display name of test 12/26/01
  1.  I BHSNGL,X["=" S X=$P(X,"=",2)
  1.  F BHSI=1:BHSL S BHSP=$E(X,BHSI,BHSL+BHSI-1) Q:BHSP=""  S BHSJ=BHSJ+1,BHSDB(BHSJ,BHSIDF)=BHSP
  1.  Q