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