BDMFLOW.m

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

HEADER ;

 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 

HEADER    ;

 +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,"-")