BDMFLOW ; IHS/CMI/LAB - flowsheet bdm ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**1,3,8**;JUN 14, 2007;Build 53
;
;
;
D FULL^VALM1,CLEAR^VALM1
D EN^XBNEW("EP^BDMFLOW","DFN")
Q
EP ;EP
W !,"Please enter the name of the Flowsheet you would like to display.",!
I '$G(DFN) W !!,"Invalid patient DFN" D EOP Q
D ^XBFMK
S DIC="^APCHSFLC(",DIC(0)="AEMQ" D ^DIC K DIC
I Y=-1 W !,"No flowsheet selected." D EXIT,EOP Q
S BDMFDF=+Y
D SETVARS
ZIS ;
W ! S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to",DIR("B")="P" K DA D ^DIR K DIR
I $D(DIRUT) D EXIT Q
I Y="B" D BROWSE,EXIT Q
S XBRP="FLOWDISP^BDMFLOW",XBRC="",XBRX="EXIT^BDMFLOW",XBNS="BDM;DFN"
D ^XBDBQUE
D EXIT
D PAUSE^BDMFMENU
Q
BROWSE ;
S XBRP="VIEWR^XBLM(""FLOWDISP^BDMFLOW"")"
S XBRC="",XBRX="EXIT^BDMFLOW",XBIOP=0 D ^XBDBQUE
Q
EXIT ;
K BDMFLOW
D ^XBFMK
Q
SETVARS ;EP
S BDMFCN=$P(^APCHSFLC(BDMFDF,0),U)
S BDMSPAT=DFN
S X=$$FMADD^XLFDT(DT,-365) ;1 YEAR PER DOROTHY, may change in future
S BDMDLM=9999999-X
S BDMNDM=-1
K BDMQIT
S BDMCKP="Q:$D(BDMQIT) S BDMNPG=0 I $Y>(IOSL-3) "
S BDMBRK="D BREAK^BDMFLOW"
I $P(IOST,"-",1)="C" S BDMCKP=BDMCKP_"W *7,""<>"" R X:DTIME S:'$T X=U W *13 S:X[U BDMQIT="""" I '$D(BDMQIT) "
S BDMCKP=BDMCKP_"W @IOF"_$S($P(IOST,"-",1)="C":",!",1:"")_" D HEADER^BDMFLOW,BREAK^BDMFLOW S BDMNPG=1"
X:$D(IO("S")) $S($D(^DD("OS",^DD("OS"),"XY")):"S (IOX,IOY)=0 X ^(""XY"")",1:"W @IOF")
S BDMCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
S BDMSPG=0
S BDMSHDR="CONFIDENTIAL PATIENT INFORMATION -- "_$$FMTE^XLFDT(DT,5)_" ["_$P(^VA(200,DUZ,0),U,2)_"]" S X="",$P(X,"*",((IOM-6-$L(BDMSHDR))\2)+1)="*" S BDMSHDR=X_" "_BDMSHDR_" "_X
Q
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR
Q
;----------
FLOWDISP ;EP ********** FLOWSHEET PRODUCTION **********
D HEADER
S BDMFNM=0
S BDMND2=BDMNDM
FLOWOUT ; <DISPLAY>
S BDMFNM=BDMFNM+1 I BDMFNM=1 X BDMCKP Q:$D(BDMQIT) X:'BDMNPG BDMBRK
S BDMFCN=$P(^APCHSFLC(BDMFDF,0),U,1)
D FLOWTB
X BDMCKP Q:$D(BDMQIT) D FLOWHD
S BDMIVD="" F BDMQ=0:0 S BDMIVD=$O(^AUPNVSIT("AA",BDMSPAT,BDMIVD)) Q:BDMIVD=""!(BDMIVD>BDMDLM) D FLOWBD Q:$D(BDMQIT) I BDMDUS S BDMNDM=BDMNDM-1 Q:BDMNDM=0
X BDMCKP Q:$D(BDMQIT) I 'BDMNPG S BDMP="",$P(BDMP,"-",BDMMXL+9)="" W ?2,BDMP,!
X BDMCKP Q:$D(BDMQIT) I 'BDMNPG W !
Q
FLOWCHK ; <SCREEN>
I '$O(^APCHSFLC(BDMFDF,2,0)) S BDMFOK=1 Q
S BDMFOK=0
F BDMPI=0:0 S BDMPI=$O(^AUPNPROB("AC",BDMSPAT,BDMPI)) Q:'BDMPI D FLOWCP Q:BDMFOK
Q:BDMFOK ;found on Problem list
PVCH ;IHS/CMI/LAB - now check for dx in past year per Bill and Charlton by pcp
K BDMY,BDMV,^TMP($J,"ALL VISITS")
S BDMY="^TMP($J,""ALL VISITS"",",%=BDMSPAT_"^ALL VISITS;DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(DT,-365))_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,BDMY)
I '$D(^TMP($J,"ALL VISITS",1)) Q
S X=0 F S X=$O(^TMP($J,"ALL VISITS",X)) Q:X'=+X!(BDMFOK) 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))
.;S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) S BDMCM=$P($G(^AUPNVPOV(Y,0)),U) I BDMCM S BDMCM=$P($G(^ICD9(BDMCM,0)),U) I BDMCM]"" D CHKCODE cmi/anch/maw 8/27/2007 orig code patch 1
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) S BDMCM=$P($G(^AUPNVPOV(Y,0)),U) I BDMCM S BDMCM=$P($$ICDDX^BDMUTL(BDMCM,$P(+V,".")),U,2) I BDMCM]"" D CHKCODE ;cmi/anch/maw 8/27/2007 code set versioning patch 1
.Q:'D
.S Y=$$PRIMPROV^APCLV(V,"F")
.Q:'Y
.Q:$P($G(^DIC(7,Y,9999999)),U,3)'="Y"
.S BDMFOK=1
.Q
K ^TMP($J,"ALL VISITS"),BDMV,BDMY
Q
FLOWCP ;
S BDMP=^AUPNPROB(BDMPI,0) Q:$P(BDMP,U,12)'="A"
S BDMCM=$P(^ICD9(+$P(BDMP,U,1),0),U,1)
F BDMCI=0:0 S BDMCI=$O(^APCHSFLC(BDMFDF,2,BDMCI)) Q:'BDMCI D FLOWCR Q:BDMFOK
Q
FLOWCR ;
S BDMC1=$P(^APCHSFLC(BDMFDF,2,BDMCI,0),U,1)
I BDMC1["-" S BDMC2=$P(BDMC1,"-",2),BDMC1=$P(BDMC1,"-",1)
E S BDMC2=BDMC1
S BDMC1=BDMC1_" ",BDMC2=BDMC2_" "
I BDMC1'](BDMCM_" "),(BDMCM_" ")']BDMC2 S BDMFOK=1
Q
CHKCODE ;
F BDMCI=0:0 S BDMCI=$O(^APCHSFLC(BDMFDF,2,BDMCI)) Q:'BDMCI D CHKCODE1 Q:D
Q
CHKCODE1 ;
S D=0
S BDMC1=$P(^APCHSFLC(BDMFDF,2,BDMCI,0),U,1)
I BDMC1["-" S BDMC2=$P(BDMC1,"-",2),BDMC1=$P(BDMC1,"-",1)
E S BDMC2=BDMC1
S BDMC1=BDMC1_" ",BDMC2=BDMC2_" "
I BDMC1'](BDMCM_" "),(BDMCM_" ")']BDMC2 S D=1
Q
FLOWCKP ;ENTRY POINT
X BDMCKP Q:$D(BDMQIT) Q:'BDMNPG
FLOWHD ;ENTRY POINT
; DISPLAY HEADER
X BDMCKP Q:$D(BDMQIT)
W BDMFCN,!
I $O(^APCHSFLC(BDMFDF,3,0)) W ?2,"Clinics limited to:" S X=0 F S X=$O(^APCHSFLC(BDMFDF,3,X)) Q:'X X BDMCKP Q:$D(BDMQIT) G:BDMNPG FLOWHD W ?22,$P(^DIC(40.7,X,0),U),!
X BDMCKP Q:$D(BDMQIT) G:BDMNPG FLOWHD
F BDMII=0:0 S BDMII=$O(BDMTB(BDMII)) Q:'BDMII W ?12+BDMTB(BDMII),BDMTB(BDMII,"L")
W !
Q
FLOWTB ; BUILD TAB TABLE
K BDMTB
S BDMT=1,BDMMXL=0
F BDMI=0:0 S BDMI=$O(^APCHSFLC(BDMFDF,1,BDMI)) Q:'BDMI D FLOWTB2
Q
FLOWTB2 S BDMW=0
Q:'($D(^APCHSFLC(BDMFDF,1,BDMI,0))#2) S BDMN=^(0)
S BDMTTL=$P(BDMN,U,3) S BDMP=$L(BDMTTL) S:BDMP>BDMW BDMW=BDMP
S BDMP=$P(BDMN,U,4) S:+BDMP>BDMW BDMW=BDMP
S:BDMW=0 BDMW=10
S BDMTB(BDMI)=BDMT_"^"_BDMW,BDMTB(BDMI,"L")=BDMTTL
S BDMMXL=BDMMXL+BDMW+2
S BDMT=BDMT+BDMW+2
Q
FLOWBD ; BUILD AND DISPLAY DATA TABLE (FOR ONE DATE)
K BDMDC
S BDMDUS=0
F BDMVDF=0:0 S BDMVDF=$O(^AUPNVSIT("AA",BDMSPAT,BDMIVD,BDMVDF)) Q:'BDMVDF D FLOWB
D:$D(BDMDC) FLOWD
Q
FLOWB S BDMCLN=$P(^AUPNVSIT(BDMVDF,0),U,8)
I BDMCLN,$O(^APCHSFLC(BDMFDF,3,0)),'$D(^(BDMCLN)) Q
S BDMDUS=1
F BDMIDF=0:0 S BDMIDF=$O(^APCHSFLC(BDMFDF,1,BDMIDF)) Q:'BDMIDF S BDMJ=0 D FLOWB2 Q:$D(BDMQIT)
Q
FLOWB2 S BDMN=^APCHSFLC(BDMFDF,1,BDMIDF,0)
S BDMIT=$P(BDMN,U,2)
S BDMFXF=$G(^APCHSFLC(BDMFDF,1,BDMIDF,1))
S BDMX=^APCHSFLI(BDMIT,1)
S BDMXT=^APCHSFLI(BDMIT,2)
S BDMP=$P(^APCHSFLI(BDMIT,0),U,3),BDMVGL=^DIC(BDMP,0,"GL")_"""AD"",BDMVDF)"
S BDMAS=$O(^APCHSFLC(BDMFDF,1,BDMIDF,2,0)),BDMNGL=BDMAS&'$O(^(BDMAS)) D FLOWBA:'BDMAS,FLOWBS:BDMAS
Q
FLOWBS ; ADD SPECIFIED ITEMS
F DA=0:0 S DA=$O(@BDMVGL@(DA)) Q:'DA D FLOWBS2
Q
FLOWBS2 ;
X BDMXT
S BDMITP=X
F I=0:0 S I=$O(^APCHSFLC(BDMFDF,1,BDMIDF,2,I)) Q:'I I +$P(^APCHSFLC(BDMFDF,1,BDMIDF,2,I,0),U,1)=BDMITP D FLOWADD Q
Q
FLOWBA ; ADD ALL (NO ITEMS SPECIFIED)
F DA=0:0 S DA=$O(@BDMVGL@(DA)) Q:'DA D FLOWADD
Q
FLOWADD ; ADD VALUE FROM SELECTED FILE/DFN
S BDML=$P(BDMTB(BDMIDF),U,2)
X BDMX
FLOWS I $L(X),$E(X,$L(X))=" " S X=$E(X,1,$L(X)-1) G FLOWS
I BDMFXF]"",$P(X,"=",2)]"" S BDMXS=$P(X,"="),X=$P(X,"=",2) X BDMFXF S X=BDMXS_"="_X
S:$E(X,$L(X))="=" X="n/r"
I $G(^APCHSFLC(BDMFDF,1,BDMIDF,1))]"" X ^APCHSFLC(BDMFDF,1,BDMIDF,1)
I BDMNGL,X["=" S X=$P(X,"=",2)
F BDMI=1:BDML S BDMP=$E(X,BDMI,BDML+BDMI-1) Q:BDMP="" S BDMJ=BDMJ+1,BDMDC(BDMJ,BDMIDF)=BDMP
Q
FLOWD ;ENTRY POINT
S Y=-BDMIVD\1+9999999 X BDMCVD S BDMDAT=Y
S BDMP="",$P(BDMP,"-",BDMMXL+9)="" X BDMCKP Q:$D(BDMQIT) W:'BDMNPG ?2,BDMP,! D:BDMNPG FLOWHD
D FLOWCKP Q:$D(BDMQIT)
W ?2,BDMDAT
F BDMI=0:0 S BDMI=$O(BDMDC(BDMI)) Q:'BDMI D FLOWCKP Q:$D(BDMQIT) D FLOWD2 W !
Q
FLOWD2 F BDMJ=0:0 S BDMJ=$O(BDMTB(BDMJ)) Q:'BDMJ W ?11+BDMTB(BDMJ),":",$G(BDMDC(BDMI,BDMJ))
Q
S BDMSPG=BDMSPG+1
S BDMSHD2=$P(^DPT(BDMSPAT,0),U)_" #"_$$HRN^AUPNPAT(BDMSPAT,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)))_" "_$$CWAD^AUPNLKID(BDMSPAT)_" pg "_BDMSPG
S BDMSP="",$P(BDMSP,"*",((IOM-6-$L(BDMSHD2))\2)+1)="*",BDMSP=BDMSP_" "_BDMSHD2_" "_BDMSP
W !,BDMSHDR,!,BDMSP,!
Q
;
BREAK ;ENTRY POINT
S BDMSP=$$CJ^XLFSTR(BDMFCN,80,"-")
I $Y'>(IOSL-5) W !,BDMSP,!! Q
W !! X BDMSCKP
Q
BDMFLOW ; IHS/CMI/LAB - flowsheet bdm ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**1,3,8**;JUN 14, 2007;Build 53
+2 ;
+3 ;
+4 ;
+5 DO FULL^VALM1
DO CLEAR^VALM1
+6 DO EN^XBNEW("EP^BDMFLOW","DFN")
+7 QUIT
EP ;EP
+1 WRITE !,"Please enter the name of the Flowsheet you would like to display.",!
+2 IF '$GET(DFN)
WRITE !!,"Invalid patient DFN"
DO EOP
QUIT
+3 DO ^XBFMK
+4 SET DIC="^APCHSFLC("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+5 IF Y=-1
WRITE !,"No flowsheet selected."
DO EXIT
DO EOP
QUIT
+6 SET BDMFDF=+Y
+7 DO SETVARS
ZIS ;
+1 WRITE !
SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"
SET DIR("A")="Do you wish to"
SET DIR("B")="P"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
DO EXIT
QUIT
+3 IF Y="B"
DO BROWSE
DO EXIT
QUIT
+4 SET XBRP="FLOWDISP^BDMFLOW"
SET XBRC=""
SET XBRX="EXIT^BDMFLOW"
SET XBNS="BDM;DFN"
+5 DO ^XBDBQUE
+6 DO EXIT
+7 DO PAUSE^BDMFMENU
+8 QUIT
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""FLOWDISP^BDMFLOW"")"
+2 SET XBRC=""
SET XBRX="EXIT^BDMFLOW"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
EXIT ;
+1 KILL BDMFLOW
+2 DO ^XBFMK
+3 QUIT
SETVARS ;EP
+1 SET BDMFCN=$PIECE(^APCHSFLC(BDMFDF,0),U)
+2 SET BDMSPAT=DFN
+3 ;1 YEAR PER DOROTHY, may change in future
SET X=$$FMADD^XLFDT(DT,-365)
+4 SET BDMDLM=9999999-X
+5 SET BDMNDM=-1
+6 KILL BDMQIT
+7 SET BDMCKP="Q:$D(BDMQIT) S BDMNPG=0 I $Y>(IOSL-3) "
+8 SET BDMBRK="D BREAK^BDMFLOW"
+9 IF $PIECE(IOST,"-",1)="C"
SET BDMCKP=BDMCKP_"W *7,""<>"" R X:DTIME S:'$T X=U W *13 S:X[U BDMQIT="""" I '$D(BDMQIT) "
+10 SET BDMCKP=BDMCKP_"W @IOF"_$SELECT($PIECE(IOST,"-",1)="C":",!",1:"")_" D HEADER^BDMFLOW,BREAK^BDMFLOW S BDMNPG=1"
+11 IF $DATA(IO("S"))
XECUTE $SELECT($DATA(^DD("OS",^DD("OS"),"XY")):"S (IOX,IOY)=0 X ^(""XY"")",1:"W @IOF")
+12 SET BDMCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
+13 SET BDMSPG=0
+14 SET BDMSHDR="CONFIDENTIAL PATIENT INFORMATION -- "_$$FMTE^XLFDT(DT,5)_" ["_$PIECE(^VA(200,DUZ,0),U,2)_"]"
SET X=""
SET $PIECE(X,"*",((IOM-6-$LENGTH(BDMSHDR))\2)+1)="*"
SET BDMSHDR=X_" "_BDMSHDR_" "_X
+15 QUIT
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;----------
FLOWDISP ;EP ********** FLOWSHEET PRODUCTION **********
+1 DO HEADER
+2 SET BDMFNM=0
+3 SET BDMND2=BDMNDM
FLOWOUT ; <DISPLAY>
+1 SET BDMFNM=BDMFNM+1
IF BDMFNM=1
XECUTE BDMCKP
IF $DATA(BDMQIT)
QUIT
IF 'BDMNPG
XECUTE BDMBRK
+2 SET BDMFCN=$PIECE(^APCHSFLC(BDMFDF,0),U,1)
+3 DO FLOWTB
+4 XECUTE BDMCKP
IF $DATA(BDMQIT)
QUIT
DO FLOWHD
+5 SET BDMIVD=""
FOR BDMQ=0:0
SET BDMIVD=$ORDER(^AUPNVSIT("AA",BDMSPAT,BDMIVD))
IF BDMIVD=""!(BDMIVD>BDMDLM)
QUIT
DO FLOWBD
IF $DATA(BDMQIT)
QUIT
IF BDMDUS
SET BDMNDM=BDMNDM-1
IF BDMNDM=0
QUIT
+6 XECUTE BDMCKP
IF $DATA(BDMQIT)
QUIT
IF 'BDMNPG
SET BDMP=""
SET $PIECE(BDMP,"-",BDMMXL+9)=""
WRITE ?2,BDMP,!
+7 XECUTE BDMCKP
IF $DATA(BDMQIT)
QUIT
IF 'BDMNPG
WRITE !
+8 QUIT
FLOWCHK ; <SCREEN>
+1 IF '$ORDER(^APCHSFLC(BDMFDF,2,0))
SET BDMFOK=1
QUIT
+2 SET BDMFOK=0
+3 FOR BDMPI=0:0
SET BDMPI=$ORDER(^AUPNPROB("AC",BDMSPAT,BDMPI))
IF 'BDMPI
QUIT
DO FLOWCP
IF BDMFOK
QUIT
+4 ;found on Problem list
IF BDMFOK
QUIT
PVCH ;IHS/CMI/LAB - now check for dx in past year per Bill and Charlton by pcp
+1 KILL BDMY,BDMV,^TMP($JOB,"ALL VISITS")
+2 SET BDMY="^TMP($J,""ALL VISITS"","
SET %=BDMSPAT_"^ALL VISITS;DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(DT,-365))_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,BDMY)
+3 IF '$DATA(^TMP($JOB,"ALL VISITS",1))
QUIT
+4 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"ALL VISITS",X))
IF X'=+X!(BDMFOK)
QUIT
SET V=$PIECE(^TMP($JOB,"ALL VISITS",X),U,5)
Begin DoDot:1
+5 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+6 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+7 IF "DAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+8 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+9 IF '$DATA(^AUPNVPOV("AD",V))
QUIT
+10 ;S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) S BDMCM=$P($G(^AUPNVPOV(Y,0)),U) I BDMCM S BDMCM=$P($G(^ICD9(BDMCM,0)),U) I BDMCM]"" D CHKCODE cmi/anch/maw 8/27/2007 orig code patch 1
+11 ;cmi/anch/maw 8/27/2007 code set versioning patch 1
SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(D)
QUIT
SET BDMCM=$PIECE($GET(^AUPNVPOV(Y,0)),U)
IF BDMCM
SET BDMCM=$PIECE($$ICDDX^BDMUTL(BDMCM,$PIECE(+V,".")),U,2)
IF BDMCM]""
DO CHKCODE
+12 IF 'D
QUIT
+13 SET Y=$$PRIMPROV^APCLV(V,"F")
+14 IF 'Y
QUIT
+15 IF $PIECE($GET(^DIC(7,Y,9999999)),U,3)'="Y"
QUIT
+16 SET BDMFOK=1
+17 QUIT
End DoDot:1
+18 KILL ^TMP($JOB,"ALL VISITS"),BDMV,BDMY
+19 QUIT
FLOWCP ;
+1 SET BDMP=^AUPNPROB(BDMPI,0)
IF $PIECE(BDMP,U,12)'="A"
QUIT
+2 SET BDMCM=$PIECE(^ICD9(+$PIECE(BDMP,U,1),0),U,1)
+3 FOR BDMCI=0:0
SET BDMCI=$ORDER(^APCHSFLC(BDMFDF,2,BDMCI))
IF 'BDMCI
QUIT
DO FLOWCR
IF BDMFOK
QUIT
+4 QUIT
FLOWCR ;
+1 SET BDMC1=$PIECE(^APCHSFLC(BDMFDF,2,BDMCI,0),U,1)
+2 IF BDMC1["-"
SET BDMC2=$PIECE(BDMC1,"-",2)
SET BDMC1=$PIECE(BDMC1,"-",1)
+3 IF '$TEST
SET BDMC2=BDMC1
+4 SET BDMC1=BDMC1_" "
SET BDMC2=BDMC2_" "
+5 IF BDMC1'](BDMCM_" ")
IF (BDMCM_" ")']BDMC2
SET BDMFOK=1
+6 QUIT
CHKCODE ;
+1 FOR BDMCI=0:0
SET BDMCI=$ORDER(^APCHSFLC(BDMFDF,2,BDMCI))
IF 'BDMCI
QUIT
DO CHKCODE1
IF D
QUIT
+2 QUIT
CHKCODE1 ;
+1 SET D=0
+2 SET BDMC1=$PIECE(^APCHSFLC(BDMFDF,2,BDMCI,0),U,1)
+3 IF BDMC1["-"
SET BDMC2=$PIECE(BDMC1,"-",2)
SET BDMC1=$PIECE(BDMC1,"-",1)
+4 IF '$TEST
SET BDMC2=BDMC1
+5 SET BDMC1=BDMC1_" "
SET BDMC2=BDMC2_" "
+6 IF BDMC1'](BDMCM_" ")
IF (BDMCM_" ")']BDMC2
SET D=1
+7 QUIT
FLOWCKP ;ENTRY POINT
+1 XECUTE BDMCKP
IF $DATA(BDMQIT)
QUIT
IF 'BDMNPG
QUIT
FLOWHD ;ENTRY POINT
+1 ; DISPLAY HEADER
+2 XECUTE BDMCKP
IF $DATA(BDMQIT)
QUIT
+3 WRITE BDMFCN,!
+4 IF $ORDER(^APCHSFLC(BDMFDF,3,0))
WRITE ?2,"Clinics limited to:"
SET X=0
FOR
SET X=$ORDER(^APCHSFLC(BDMFDF,3,X))
IF 'X
QUIT
XECUTE BDMCKP
IF $DATA(BDMQIT)
QUIT
IF BDMNPG
GOTO FLOWHD
WRITE ?22,$PIECE(^DIC(40.7,X,0),U),!
+5 XECUTE BDMCKP
IF $DATA(BDMQIT)
QUIT
IF BDMNPG
GOTO FLOWHD
+6 FOR BDMII=0:0
SET BDMII=$ORDER(BDMTB(BDMII))
IF 'BDMII
QUIT
WRITE ?12+BDMTB(BDMII),BDMTB(BDMII,"L")
+7 WRITE !
+8 QUIT
FLOWTB ; BUILD TAB TABLE
+1 KILL BDMTB
+2 SET BDMT=1
SET BDMMXL=0
+3 FOR BDMI=0:0
SET BDMI=$ORDER(^APCHSFLC(BDMFDF,1,BDMI))
IF 'BDMI
QUIT
DO FLOWTB2
+4 QUIT
FLOWTB2 SET BDMW=0
+1 IF '($DATA(^APCHSFLC(BDMFDF,1,BDMI,0))#2)
QUIT
SET BDMN=^(0)
+2 SET BDMTTL=$PIECE(BDMN,U,3)
SET BDMP=$LENGTH(BDMTTL)
IF BDMP>BDMW
SET BDMW=BDMP
+3 SET BDMP=$PIECE(BDMN,U,4)
IF +BDMP>BDMW
SET BDMW=BDMP
+4 IF BDMW=0
SET BDMW=10
+5 SET BDMTB(BDMI)=BDMT_"^"_BDMW
SET BDMTB(BDMI,"L")=BDMTTL
+6 SET BDMMXL=BDMMXL+BDMW+2
+7 SET BDMT=BDMT+BDMW+2
+8 QUIT
FLOWBD ; BUILD AND DISPLAY DATA TABLE (FOR ONE DATE)
+1 KILL BDMDC
+2 SET BDMDUS=0
+3 FOR BDMVDF=0:0
SET BDMVDF=$ORDER(^AUPNVSIT("AA",BDMSPAT,BDMIVD,BDMVDF))
IF 'BDMVDF
QUIT
DO FLOWB
+4 IF $DATA(BDMDC)
DO FLOWD
+5 QUIT
FLOWB SET BDMCLN=$PIECE(^AUPNVSIT(BDMVDF,0),U,8)
+1 IF BDMCLN
IF $ORDER(^APCHSFLC(BDMFDF,3,0))
IF '$DATA(^(BDMCLN))
QUIT
+2 SET BDMDUS=1
+3 FOR BDMIDF=0:0
SET BDMIDF=$ORDER(^APCHSFLC(BDMFDF,1,BDMIDF))
IF 'BDMIDF
QUIT
SET BDMJ=0
DO FLOWB2
IF $DATA(BDMQIT)
QUIT
+4 QUIT
FLOWB2 SET BDMN=^APCHSFLC(BDMFDF,1,BDMIDF,0)
+1 SET BDMIT=$PIECE(BDMN,U,2)
+2 SET BDMFXF=$GET(^APCHSFLC(BDMFDF,1,BDMIDF,1))
+3 SET BDMX=^APCHSFLI(BDMIT,1)
+4 SET BDMXT=^APCHSFLI(BDMIT,2)
+5 SET BDMP=$PIECE(^APCHSFLI(BDMIT,0),U,3)
SET BDMVGL=^DIC(BDMP,0,"GL")_"""AD"",BDMVDF)"
+6 SET BDMAS=$ORDER(^APCHSFLC(BDMFDF,1,BDMIDF,2,0))
SET BDMNGL=BDMAS&'$ORDER(^(BDMAS))
IF 'BDMAS
DO FLOWBA
IF BDMAS
DO FLOWBS
+7 QUIT
FLOWBS ; ADD SPECIFIED ITEMS
+1 FOR DA=0:0
SET DA=$ORDER(@BDMVGL@(DA))
IF 'DA
QUIT
DO FLOWBS2
+2 QUIT
FLOWBS2 ;
+1 XECUTE BDMXT
+2 SET BDMITP=X
+3 FOR I=0:0
SET I=$ORDER(^APCHSFLC(BDMFDF,1,BDMIDF,2,I))
IF 'I
QUIT
IF +$PIECE(^APCHSFLC(BDMFDF,1,BDMIDF,2,I,0),U,1)=BDMITP
DO FLOWADD
QUIT
+4 QUIT
FLOWBA ; ADD ALL (NO ITEMS SPECIFIED)
+1 FOR DA=0:0
SET DA=$ORDER(@BDMVGL@(DA))
IF 'DA
QUIT
DO FLOWADD
+2 QUIT
FLOWADD ; ADD VALUE FROM SELECTED FILE/DFN
+1 SET BDML=$PIECE(BDMTB(BDMIDF),U,2)
+2 XECUTE BDMX
FLOWS IF $LENGTH(X)
IF $EXTRACT(X,$LENGTH(X))=" "
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
GOTO FLOWS
+1 IF BDMFXF]""
IF $PIECE(X,"=",2)]""
SET BDMXS=$PIECE(X,"=")
SET X=$PIECE(X,"=",2)
XECUTE BDMFXF
SET X=BDMXS_"="_X
+2 IF $EXTRACT(X,$LENGTH(X))="="
SET X="n/r"
+3 IF $GET(^APCHSFLC(BDMFDF,1,BDMIDF,1))]""
XECUTE ^APCHSFLC(BDMFDF,1,BDMIDF,1)
+4 IF BDMNGL
IF X["="
SET X=$PIECE(X,"=",2)
+5 FOR BDMI=1:BDML
SET BDMP=$EXTRACT(X,BDMI,BDML+BDMI-1)
IF BDMP=""
QUIT
SET BDMJ=BDMJ+1
SET BDMDC(BDMJ,BDMIDF)=BDMP
+6 QUIT
FLOWD ;ENTRY POINT
+1 SET Y=-BDMIVD\1+9999999
XECUTE BDMCVD
SET BDMDAT=Y
+2 SET BDMP=""
SET $PIECE(BDMP,"-",BDMMXL+9)=""
XECUTE BDMCKP
IF $DATA(BDMQIT)
QUIT
IF 'BDMNPG
WRITE ?2,BDMP,!
IF BDMNPG
DO FLOWHD
+3 DO FLOWCKP
IF $DATA(BDMQIT)
QUIT
+4 WRITE ?2,BDMDAT
+5 FOR BDMI=0:0
SET BDMI=$ORDER(BDMDC(BDMI))
IF 'BDMI
QUIT
DO FLOWCKP
IF $DATA(BDMQIT)
QUIT
DO FLOWD2
WRITE !
+6 QUIT
FLOWD2 FOR BDMJ=0:0
SET BDMJ=$ORDER(BDMTB(BDMJ))
IF 'BDMJ
QUIT
WRITE ?11+BDMTB(BDMJ),":",$GET(BDMDC(BDMI,BDMJ))
+1 QUIT
+1 SET BDMSPG=BDMSPG+1
+2 SET BDMSHD2=$PIECE(^DPT(BDMSPAT,0),U)_" #"_$$HRN^AUPNPAT(BDMSPAT,$SELECT($GET(BDMDUZ2):BDMDUZ2,1:DUZ(2)))_" "_$$CWAD^AUPNLKID(BDMSPAT)_" pg "_BDMSPG
+3 SET BDMSP=""
SET $PIECE(BDMSP,"*",((IOM-6-$LENGTH(BDMSHD2))\2)+1)="*"
SET BDMSP=BDMSP_" "_BDMSHD2_" "_BDMSP
+4 WRITE !,BDMSHDR,!,BDMSP,!
+5 QUIT
+6 ;
BREAK ;ENTRY POINT
+1 SET BDMSP=$$CJ^XLFSTR(BDMFCN,80,"-")
+2 IF $Y'>(IOSL-5)
WRITE !,BDMSP,!!
QUIT
+3 WRITE !!
XECUTE BDMSCKP
+4 QUIT
