BDMFS.m

BDMFS ; IHS/CMI/LAB - DMS FLOW SHEET MANAGEMENT UTILITY ;

 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007

 ;UTILITY PROGRAM TO MANAGE FLOW SHEET CREATION AND EDITING

FS ;EP;FLOW SHEET MANAGEMENT

 S IOP="HOME"

 D ^%ZIS

 D FS1 Q:$D(BDMQUIT)!$D(BDMOUT)

FSEXIT K BDMQUIT,BDMOUT,BDMJ,BDMX,BDMY,BDMSDA,BDMSNAM,BDMCINK,BDMCNK0,BDMCDA,BDMWHCH,BDMADA,BDMANAM,BDMSF,BDMCANN,BDMGO

 K ^TMP("BDMVR",$J)

 Q

FS1 D FSEXIT

 D FSDISP

 Q

FSDISP ;DISPLAY FLOW SHEET

 D VALM("BDM FLOW SHEET LIST")

 Q

FSHEAD ;PRINT HEADER FOR FLOW SHEET MANAGEMENT

 W @IOF

FSHEAD1 N X

 F X="DIABETES MANAGEMENT SYSTEM","FLOW SHEET MANAGEMENT" D

 .W !?(80-$L(X))\2,X

 Q

DXHEAD ;PRINT HEADER FOR FLOW SHEET MANAGEMENT

 W @IOF

 D FSHEAD1

 N X

 F X="Diagnosti/Medication Flow Sheets"

 W !?(80-$L(X))\2,X

 Q

FSDH ;DISPLAY HEADER FOR FLOW SHEET SYSTEM

 Q

FSADD ;EP;ENTER A NEW FLOW SHEET

 S DIR(0)="FO^3:30"

 S DIR("A")="Flow Sheet Name"

 W !

 D DIR^BDMDIC

 I Y="" S BDMQUIT="" D TABACK Q

 I X="^" S BDMQUIT="" D TABACK Q

 S (X,BDMSNAM)=Y

 S DIC="^APCHSFLC("

 S DIC(0)="L"

 D FILE^BDMDIC

 S BDMSDA=+Y

 I 'BDMSDA D TABACK Q

 D FSCEDIT

 D FSCLIST

TABACK S BDMGO="FS"

 D BACK

 Q

FSEDIT ;EP;EDIT AN EXISTING FLOW SHEET

 D SELECT

 I $D(BDMQUIT) K BDMQUIT D TEBACK Q

 D FSCLIST

TEBACK S BDMGO="FS"

 D BACK

 Q

SELECT ;SELECT AN EXISTING FLOW SHEET

 S DIR(0)="NO^1:"_BDMJ

 S DIR("A")="Which Flow Sheet"

 W !

 D DIR^BDMDIC

 I Y<1 S BDMQUIT="" Q

 Q:'$D(BDMJ(Y))

 S BDMSDA=+BDMJ(Y)

 S BDMSNAM=$P(BDMJ(Y),U,2)

 D FSCLIST

 Q

FSCEDIT ;EP;EDIT A FLOW SHEET COMPONENT

 S DA=BDMSDA

 S DIE="^APCHSFLC("

 S DR="[BDM FLOW SHEET COMPONENT]"

 D DDS^BDMDIC

 S BDMGO="FSC"

 D BACK

 Q

FSINIT ;EP;INITIALIZE ARRAY FOR FLOW SHEET DISPLAY

 K ^TMP("BDMVR",$J),BDMJ

 S VALMCNT=0

 S X="     NO. Flow sheet"

 D Z(X)

 S X="     --- ------------------------------"

 D Z(X)

 N I,J,X,Y,Z

 S I=0

 S X=""

 F  S X=$O(^APCHSFLC("B",X)) Q:X=""  D

 .S Y=0

 .F  S Y=$O(^APCHSFLC("B",X,Y)) Q:'Y  D

 ..S I=I+1

 ..S A="    "_I

 ..S:$L(A)=5 A=" "_A

 ..S A=A_"   "_X

 ..D Z(A)

 ..S BDMJ(I)=Y_U_X

 I '$D(^TMP("BDMVR",$J)) D

 .S VALMCNT=2

 .S X="NO FLOW SHEET ON FILE FOR "_BDMX

 .D Z(X)

 S BDMJ=I

 Q

VALM(BDMX) ;VALM INTERFACE

 S VALMCC=1 ;1=screen mode, 0=scrolling mode

 D TERM^VALM0

 D EN^VALM(BDMX)

 D CLEAR^VALM1

 Q

FSCLIST ;EP;TO DISPLAY ITEMS ON FLOW SHEET LIST

 D VALM("BDM FLOW SHEET COMPONENT LIST")

 Q

FSCINIT ;EP;TO LIST ITEMS ON FLOW SHEET

 N A,B,J,X,Y,Z,BDMTYPE,BDMABEL

 K ^TMP("BDMVR",$J),BDMJ,BDMCS

 S VALMCNT=0

 S X="     "_BDMSNAM

 D Z(X)

 S X="   "

 D Z(X)

 S X="     Flowsheet Components"

 D Z(X)

 S X="     NO.  ORDER  TYPE                 LABEL                 WIDTH"

 D Z(X)

 S X="     ---  -----  -------------------  --------------------  -----"

 D Z(X)

 S (J,BDMX)=0

 F  S BDMX=$O(^APCHSFLC(BDMSDA,1,"B",BDMX)) Q:'BDMX  D

 .S BDMCDA=0

 .F  S BDMCDA=$O(^APCHSFLC(BDMSDA,1,"B",BDMX,BDMCDA)) Q:'BDMCDA  D

 ..S X=$G(^APCHSFLC(BDMSDA,1,BDMCDA,0))

 ..Q:X=""

 ..S J=J+1

 ..S A="     "_J

 ..S:$L(A)=6 A=A_" "

 ..S A=A_"    "

 ..S A=A_$P(X,U)

 ..S:$L($P(X,U))=1 A=A_" "

 ..S A=A_"    "

 ..S BDMTYPE=$P($G(^APCHSFLI(+$P(X,U,2),0)),U)

 ..S BDMTYPE=BDMTYPE_$E("                    ",1,20-$L(BDMTYPE))

 ..S A=A_BDMTYPE

 ..S A=A_" "

 ..S BDMABEL=$P(X,U,3)

 ..S BDMABEL=BDMABEL_$E("                    ",1,20-$L(BDMABEL))

 ..S A=A_BDMABEL

 ..S A=A_"   "

 ..S BDMWDTH=$P(X,U,4)

 ..S A=A_BDMWDTH

 ..S X=A

 ..D Z(X)

 ..S BDMJ(BDMSDA,J)=BDMCDA_U_A

 ..D MEMLIST

 S BDMJ=J

 Q

FSCADD ;EP;TO ADD ITEM TO FLOW SHEET

 K BDM

 N X,Y

 I BDMANAM="DIAGNOSIS"!(BDMSNAM="PROBLEM LIST DIAGNOSIS") D  I 1

 .S X=0

 .F  S X=$O(^APCHSFLC(BDMSDA,1,X)) Q:'X  D

 ..S Y=$G(^APCHSFLC(BDMSDA,1,X,0))

 ..S:$P(Y,U)]"" BDM(X)=$P(Y,U)_U_$S($P(Y,U,2)]"":$P(Y,U,2),1:$P(Y,U))

 .D ^BDMFS1

 .Q:$D(BDMQUIT)

 .S X=$P(BDM("LOW"),U)

 E  D

 .D CLEAR^VALM1

 .W !?5,"Select an item to ADD to the"

 .W !!?5,BDMSNAM," Flow Sheet"

 .S DIC=BDMSF

 .S DIC(0)="AEMQZ"

 .S DIC("A")="Which "_BDMANAM_": "

 .W !

 .D DIC^BDMDIC

 .I +Y<1 S BDMQUIT="" Q

 .S BDM("LOW")=+Y

 .D X

 .S BDM("HIGH")=""

 I $D(BDMQUIT) D FSCBACK Q

 S DA(1)=BDMSDA

 S DIC="^APCHSFLC("_BDMSDA_",1,"

 S DIC(0)="L"

 S DIC("DR")=".02////"_BDM("HIGH")

 D FILE^BDMDIC:'$D(^APCHSFLC(BDMSDA,1,"B",X))

FSCBACK ;EP;S BDMGO="FSC"

 D BACK

 Q

X ;EVALUATE X FOR PROPER INTERNAL VALUE

 I BDMANAM="ADA CODE" S X=Y(0,0)

 I BDMANAM="RX" S X=+Y

 I BDMANAM="PROCEDURE (MEDICAL)" S X=Y(0,0)

 I BDMANAM="PATIENT ED TOPIC" S X=+Y

 I BDMANAM="HEALTH FACTORS" S X=+Y

 I BDMANAM="PROBLEM LIST DIAGNOSIS" S X=Y(0,0)

 Q

FSCDEL ;EP;TO DELETE ITEM FROM FLOW SHEET

 D FSCSEL

 I $D(BDMQUIT) K BDMQUIT D FSCBACK Q

 N BDMI,BDMX

 F BDMI=1:1 S BDMX=$P(BDMY,",",BDMI) Q:BDMX=""  D

 .Q:'$D(BDMJ(BDMSDA,BDMX))

 .S BDMCDA=+BDMJ(BDMSDA,BDMX)

 .S DA(1)=BDMSDA

 .S DA=BDMCDA

 .S DIK="^APCHSFLC("_DA(1)_",1,"

 .D DIK^BDMDIC

 S BDMGO="FSC"

 D BACK

 Q

FSCSEL ;EP;SELECT EXISTING ITEM FROM A FLOW SHEET

 S DIR(0)="LO^1:"_BDMJ

 S DIR("A")="Whick Flow Sheet Component(s)"

 W !

 D DIR^BDMDIC

 I Y<1 S BDMQUIT="" Q

 S BDMY=Y

 Q

BACK ;EP;SETUP FOR RETURN TO LISTMAN

 S VALMBCK="R"

 D FSINIT:BDMGO="FS"

 D FSCINIT:BDMGO="FSC"

 D MEMINIT:BDMGO="FSM"

 D TERM^VALM0

 Q

MEMBERS ;EP;TO SPECIFY THE MEMBERS FOR A FLOW SHEET COMPONENT

 D FSCSEL

 I $D(BDMQUIT) K BDMQUIT D FSCBACK Q

 F BDMI=1:1 S BDMX=$P(BDMY,",",BDMI) Q:BDMX=""!$D(BDMQUIT)  D

 .Q:'$D(BDMJ(BDMSDA,BDMX))

 .S BDMCDA=+BDMJ(BDMSDA,BDMX)

 .Q:'BDMCDA

 .S BDMTYPE=$G(^APCHSFLI(+$P($G(^APCHSFLC(+BDMSDA,1,+BDMCDA,0)),U,2),0))

 .D MEMDISP

 Q

MEMSEL ;SELECT THE MEMBER OF THE COMPONENT TO EDIT OR DELETE

 S DIR(0)="LO^1:"_BDMJ

 S DIR("A")="Whick Component Members(s)"

 W !

 D DIR^BDMDIC

 I Y<1 S BDMQUIT="" Q

 S BDMY=Y

 Q

MEMADD ;EP;TO ADD MEMBERS TO A FLOW SHEET COMPONENT

 S BDMTYPE=$G(^APCHSFLI(+$P($G(^APCHSFLC(+BDMSDA,1,+BDMCDA,0)),U,2),0))

 F  D MADD1 Q:$D(BDMQUIT)

 K BDMQUIT

 D MBACK

 Q

MADD1 W @IOF

 W !?5,"Select"

 W !?5,$P(BDMTYPE,U),?25,"to add to the"

 W !?5,$P(BDMTYPE,U),?25,"component of the "

 W !?5,BDMSNAM,?25,"Flow Sheet"

 S DIC=+$P(BDMTYPE,U,2)

 I 'DIC S BDMQUIT="" Q

 S DIC=^DIC(DIC,0,"GL")

 I DIC="" S BDMQUIT="" Q

 S BDMDIC=DIC

 S DIC(0)="AEMQZ"

 S DIC("A")="Which "_$P(BDMTYPE,U)_": "

 W !

 D DIC^BDMDIC

 I +Y<1 S BDMQUIT="" Q

 S X=+Y_";"_$E(BDMDIC,2,99)

 S $P(^APCHSFLC(BDMSDA,1,BDMCDA,2,0),U,2)="9001020.15AV"

 S DA(2)=BDMSDA

 S DA(1)=BDMCDA

 S DIC="^APCHSFLC("_BDMSDA_",1,"_BDMCDA_",2,"

 S DIC(0)="L"

 D FILE^BDMDIC

 Q

MEMDEL ;EP;TO DELETE MEMBERS FROM A FLOW SHEET COMPONENT

 N BDMY

 D MEMSEL

 I $D(BDMQUIT) K BDMQUIT D MBACK Q

 F BDMI=1:1 S BDMX=$P(BDMY,",",BDMI) Q:BDMX=""  D

 .Q:'$D(BDMJ(BDMSDA,BDMCDA,BDMX))

 .S DA=+BDMJ(BDMSDA,BDMCDA,BDMX)

 .S DA(2)=BDMSDA

 .S DA(1)=BDMCDA

 .S DIK="^APCHSFLC("_DA(2)_",1,"_DA(1)_",2,"

 .D DIK^BDMDIC

MBACK S BDMGO="FSM"

 D BACK

 Q

DELETE ;EP;TO DELETE FLOW SHEET COMPONENT

 Q

MEMDISP ;DISPLAY MEMBERS OF A COMPONENT

 D VALM("BDM FLOW SHEET MEMBERS")

 Q

MEMINIT ;EP;TO LIST ITEMS ON FLOW SHEET

 K ^TMP("BDMVR",$J),BDMJ

 S VALMCNT=0

 S X="     "_$P(BDMTYPE,U)

 D Z(X)

 S X="     ---------------------------"

 D Z(X)

 N A,B,X,Y

 S BDMMDA=0

 F  S BDMMDA=$O(^APCHSFLC(BDMSDA,1,BDMCDA,2,BDMMDA)) Q:'BDMMDA  D

 .S X=$G(^APCHSFLC(BDMSDA,1,BDMCDA,2,BDMMDA,0))

 .Q:X=""

 .S BDMGL=U_$P(X,";",2)

 .S:$E(BDMGL,$L(BDMGL))="(" BDMGL=$E(BDMGL,1,$L(BDMGL)-1)

 .S:$E(BDMGL,$L(BDMGL))="," BDMGL=$E(BDMGL,1,$L(BDMGL)-1)_")"

 .S BDMDA=+X

 .S X=$P($G(@BDMGL@(+X,0)),U,$S(BDMGL'["AUTTMSR":1,1:2))

 .S A="     "_(VALMCNT-1)

 .S:$L(A)=6 A=A_" "

 .S A=A_"    "

 .S A=A_X

 .S X=A

 .D Z(X)

 .S BDMJ(BDMSDA,BDMCDA,VALMCNT-2)=BDMMDA_U_A

 S BDMJ=VALMCNT-2

 Q

MEMLIST ;LIST MEMBERS OF EACH COMPONENT FOR DISPLAY WITH COMPONENTS

 N J,X,Y,BDMX,BDMMDA

 S (J,BDMMDA)=0

 F  S BDMMDA=$O(^APCHSFLC(BDMSDA,1,BDMCDA,2,BDMMDA)) Q:'BDMMDA  D

 .S X=$G(^APCHSFLC(BDMSDA,1,BDMCDA,2,BDMMDA,0))

 .Q:X=""

 .S J=J+1

 .S BDMGL=U_$P(X,";",2)

 .S:$E(BDMGL,$L(BDMGL))="(" BDMGL=$E(BDMGL,1,$L(BDMGL)-1)

 .S:$E(BDMGL,$L(BDMGL))="," BDMGL=$E(BDMGL,1,$L(BDMGL)-1)_")"

 .S X=$P($G(@BDMGL@(+X,0)),U,$S(BDMGL'["AUTTMSR":1,1:2))

 .S A="                 "_X

 .S X=A

 .D Z(X)

 Q

HEADER ;EP;TO SET HEADER CODE

 S VALMSG="- Prev Screen  QU Quit  ?? More Actions"

 Q

Z(X) ;SET TMP GLOBAL

 S VALMCNT=VALMCNT+1

 S ^TMP("BDMVR",$J,VALMCNT,0)=X

 Q

BDMFS     ; IHS/CMI/LAB - DMS FLOW SHEET MANAGEMENT UTILITY ;

 +1       ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007

 +2       ;UTILITY PROGRAM TO MANAGE FLOW SHEET CREATION AND EDITING

FS        ;EP;FLOW SHEET MANAGEMENT

 +1        SET IOP="HOME"

 +2        DO ^%ZIS

 +3        DO FS1

           IF $DATA(BDMQUIT)!$DATA(BDMOUT)

               QUIT 

FSEXIT     KILL BDMQUIT,BDMOUT,BDMJ,BDMX,BDMY,BDMSDA,BDMSNAM,BDMCINK,BDMCNK0,BDMCDA,BDMWHCH,BDMADA,BDMANAM,BDMSF,BDMCANN,BDMGO

 +1        KILL ^TMP("BDMVR",$JOB)

 +2        QUIT 

FS1        DO FSEXIT

 +1        DO FSDISP

 +2        QUIT 

FSDISP    ;DISPLAY FLOW SHEET

 +1        DO VALM("BDM FLOW SHEET LIST")

 +2        QUIT 

FSHEAD    ;PRINT HEADER FOR FLOW SHEET MANAGEMENT

 +1        WRITE @IOF

FSHEAD1    NEW X

 +1        FOR X="DIABETES MANAGEMENT SYSTEM","FLOW SHEET MANAGEMENT"

               Begin DoDot:1

 +2                WRITE !?(80-$LENGTH(X))\2,X

               End DoDot:1

 +3        QUIT 

DXHEAD    ;PRINT HEADER FOR FLOW SHEET MANAGEMENT

 +1        WRITE @IOF

 +2        DO FSHEAD1

 +3        NEW X

 +4        FOR X="Diagnosti/Medication Flow Sheets"

 +5        WRITE !?(80-$LENGTH(X))\2,X

 +6        QUIT 

FSDH      ;DISPLAY HEADER FOR FLOW SHEET SYSTEM

 +1        QUIT 

FSADD     ;EP;ENTER A NEW FLOW SHEET

 +1        SET DIR(0)="FO^3:30"

 +2        SET DIR("A")="Flow Sheet Name"

 +3        WRITE !

 +4        DO DIR^BDMDIC

 +5        IF Y=""

               SET BDMQUIT=""

               DO TABACK

               QUIT 

 +6        IF X="^"

               SET BDMQUIT=""

               DO TABACK

               QUIT 

 +7        SET (X,BDMSNAM)=Y

 +8        SET DIC="^APCHSFLC("

 +9        SET DIC(0)="L"

 +10       DO FILE^BDMDIC

 +11       SET BDMSDA=+Y

 +12       IF 'BDMSDA

               DO TABACK

               QUIT 

 +13       DO FSCEDIT

 +14       DO FSCLIST

TABACK     SET BDMGO="FS"

 +1        DO BACK

 +2        QUIT 

FSEDIT    ;EP;EDIT AN EXISTING FLOW SHEET

 +1        DO SELECT

 +2        IF $DATA(BDMQUIT)

               KILL BDMQUIT

               DO TEBACK

               QUIT 

 +3        DO FSCLIST

TEBACK     SET BDMGO="FS"

 +1        DO BACK

 +2        QUIT 

SELECT    ;SELECT AN EXISTING FLOW SHEET

 +1        SET DIR(0)="NO^1:"_BDMJ

 +2        SET DIR("A")="Which Flow Sheet"

 +3        WRITE !

 +4        DO DIR^BDMDIC

 +5        IF Y<1

               SET BDMQUIT=""

               QUIT 

 +6        IF '$DATA(BDMJ(Y))

               QUIT 

 +7        SET BDMSDA=+BDMJ(Y)

 +8        SET BDMSNAM=$PIECE(BDMJ(Y),U,2)

 +9        DO FSCLIST

 +10       QUIT 

FSCEDIT   ;EP;EDIT A FLOW SHEET COMPONENT

 +1        SET DA=BDMSDA

 +2        SET DIE="^APCHSFLC("

 +3        SET DR="[BDM FLOW SHEET COMPONENT]"

 +4        DO DDS^BDMDIC

 +5        SET BDMGO="FSC"

 +6        DO BACK

 +7        QUIT 

FSINIT    ;EP;INITIALIZE ARRAY FOR FLOW SHEET DISPLAY

 +1        KILL ^TMP("BDMVR",$JOB),BDMJ

 +2        SET VALMCNT=0

 +3        SET X="     NO. Flow sheet"

 +4        DO Z(X)

 +5        SET X="     --- ------------------------------"

 +6        DO Z(X)

 +7        NEW I,J,X,Y,Z

 +8        SET I=0

 +9        SET X=""

 +10       FOR 

               SET X=$ORDER(^APCHSFLC("B",X))

               IF X=""

                   QUIT 

               Begin DoDot:1

 +11               SET Y=0

 +12               FOR 

                       SET Y=$ORDER(^APCHSFLC("B",X,Y))

                       IF 'Y

                           QUIT 

                       Begin DoDot:2

 +13                       SET I=I+1

 +14                       SET A="    "_I

 +15                       IF $LENGTH(A)=5

                               SET A=" "_A

 +16                       SET A=A_"   "_X

 +17                       DO Z(A)

 +18                       SET BDMJ(I)=Y_U_X

                       End DoDot:2

               End DoDot:1

 +19       IF '$DATA(^TMP("BDMVR",$JOB))

               Begin DoDot:1

 +20               SET VALMCNT=2

 +21               SET X="NO FLOW SHEET ON FILE FOR "_BDMX

 +22               DO Z(X)

               End DoDot:1

 +23       SET BDMJ=I

 +24       QUIT 

VALM(BDMX) ;VALM INTERFACE

 +1       ;1=screen mode, 0=scrolling mode

           SET VALMCC=1

 +2        DO TERM^VALM0

 +3        DO EN^VALM(BDMX)

 +4        DO CLEAR^VALM1

 +5        QUIT 

FSCLIST   ;EP;TO DISPLAY ITEMS ON FLOW SHEET LIST

 +1        DO VALM("BDM FLOW SHEET COMPONENT LIST")

 +2        QUIT 

FSCINIT   ;EP;TO LIST ITEMS ON FLOW SHEET

 +1        NEW A,B,J,X,Y,Z,BDMTYPE,BDMABEL

 +2        KILL ^TMP("BDMVR",$JOB),BDMJ,BDMCS

 +3        SET VALMCNT=0

 +4        SET X="     "_BDMSNAM

 +5        DO Z(X)

 +6        SET X="   "

 +7        DO Z(X)

 +8        SET X="     Flowsheet Components"

 +9        DO Z(X)

 +10       SET X="     NO.  ORDER  TYPE                 LABEL                 WIDTH"

 +11       DO Z(X)

 +12       SET X="     ---  -----  -------------------  --------------------  -----"

 +13       DO Z(X)

 +14       SET (J,BDMX)=0

 +15       FOR 

               SET BDMX=$ORDER(^APCHSFLC(BDMSDA,1,"B",BDMX))

               IF 'BDMX

                   QUIT 

               Begin DoDot:1

 +16               SET BDMCDA=0

 +17               FOR 

                       SET BDMCDA=$ORDER(^APCHSFLC(BDMSDA,1,"B",BDMX,BDMCDA))

                       IF 'BDMCDA

                           QUIT 

                       Begin DoDot:2

 +18                       SET X=$GET(^APCHSFLC(BDMSDA,1,BDMCDA,0))

 +19                       IF X=""

                               QUIT 

 +20                       SET J=J+1

 +21                       SET A="     "_J

 +22                       IF $LENGTH(A)=6

                               SET A=A_" "

 +23                       SET A=A_"    "

 +24                       SET A=A_$PIECE(X,U)

 +25                       IF $LENGTH($PIECE(X,U))=1

                               SET A=A_" "

 +26                       SET A=A_"    "

 +27                       SET BDMTYPE=$PIECE($GET(^APCHSFLI(+$PIECE(X,U,2),0)),U)

 +28                       SET BDMTYPE=BDMTYPE_$EXTRACT("                    ",1,20-$LENGTH(BDMTYPE))

 +29                       SET A=A_BDMTYPE

 +30                       SET A=A_" "

 +31                       SET BDMABEL=$PIECE(X,U,3)

 +32                       SET BDMABEL=BDMABEL_$EXTRACT("                    ",1,20-$LENGTH(BDMABEL))

 +33                       SET A=A_BDMABEL

 +34                       SET A=A_"   "

 +35                       SET BDMWDTH=$PIECE(X,U,4)

 +36                       SET A=A_BDMWDTH

 +37                       SET X=A

 +38                       DO Z(X)

 +39                       SET BDMJ(BDMSDA,J)=BDMCDA_U_A

 +40                       DO MEMLIST

                       End DoDot:2

               End DoDot:1

 +41       SET BDMJ=J

 +42       QUIT 

FSCADD    ;EP;TO ADD ITEM TO FLOW SHEET

 +1        KILL BDM

 +2        NEW X,Y

 +3        IF BDMANAM="DIAGNOSIS"!(BDMSNAM="PROBLEM LIST DIAGNOSIS")

               Begin DoDot:1

 +4                SET X=0

 +5                FOR 

                       SET X=$ORDER(^APCHSFLC(BDMSDA,1,X))

                       IF 'X

                           QUIT 

                       Begin DoDot:2

 +6                        SET Y=$GET(^APCHSFLC(BDMSDA,1,X,0))

 +7                        IF $PIECE(Y,U)]""

                               SET BDM(X)=$PIECE(Y,U)_U_$SELECT($PIECE(Y,U,2)]"":$PIECE(Y,U,2),1:$PIECE(Y,U))

                       End DoDot:2

 +8                DO ^BDMFS1

 +9                IF $DATA(BDMQUIT)

                       QUIT 

 +10               SET X=$PIECE(BDM("LOW"),U)

               End DoDot:1

               IF 1

 +11      IF '$TEST

               Begin DoDot:1

 +12               DO CLEAR^VALM1

 +13               WRITE !?5,"Select an item to ADD to the"

 +14               WRITE !!?5,BDMSNAM," Flow Sheet"

 +15               SET DIC=BDMSF

 +16               SET DIC(0)="AEMQZ"

 +17               SET DIC("A")="Which "_BDMANAM_": "

 +18               WRITE !

 +19               DO DIC^BDMDIC

 +20               IF +Y<1

                       SET BDMQUIT=""

                       QUIT 

 +21               SET BDM("LOW")=+Y

 +22               DO X

 +23               SET BDM("HIGH")=""

               End DoDot:1

 +24       IF $DATA(BDMQUIT)

               DO FSCBACK

               QUIT 

 +25       SET DA(1)=BDMSDA

 +26       SET DIC="^APCHSFLC("_BDMSDA_",1,"

 +27       SET DIC(0)="L"

 +28       SET DIC("DR")=".02////"_BDM("HIGH")

 +29       IF '$DATA(^APCHSFLC(BDMSDA,1,"B",X))

               DO FILE^BDMDIC

FSCBACK   ;EP;S BDMGO="FSC"

 +1        DO BACK

 +2        QUIT 

X         ;EVALUATE X FOR PROPER INTERNAL VALUE

 +1        IF BDMANAM="ADA CODE"

               SET X=Y(0,0)

 +2        IF BDMANAM="RX"

               SET X=+Y

 +3        IF BDMANAM="PROCEDURE (MEDICAL)"

               SET X=Y(0,0)

 +4        IF BDMANAM="PATIENT ED TOPIC"

               SET X=+Y

 +5        IF BDMANAM="HEALTH FACTORS"

               SET X=+Y

 +6        IF BDMANAM="PROBLEM LIST DIAGNOSIS"

               SET X=Y(0,0)

 +7        QUIT 

FSCDEL    ;EP;TO DELETE ITEM FROM FLOW SHEET

 +1        DO FSCSEL

 +2        IF $DATA(BDMQUIT)

               KILL BDMQUIT

               DO FSCBACK

               QUIT 

 +3        NEW BDMI,BDMX

 +4        FOR BDMI=1:1

               SET BDMX=$PIECE(BDMY,",",BDMI)

               IF BDMX=""

                   QUIT 

               Begin DoDot:1

 +5                IF '$DATA(BDMJ(BDMSDA,BDMX))

                       QUIT 

 +6                SET BDMCDA=+BDMJ(BDMSDA,BDMX)

 +7                SET DA(1)=BDMSDA

 +8                SET DA=BDMCDA

 +9                SET DIK="^APCHSFLC("_DA(1)_",1,"

 +10               DO DIK^BDMDIC

               End DoDot:1

 +11       SET BDMGO="FSC"

 +12       DO BACK

 +13       QUIT 

FSCSEL    ;EP;SELECT EXISTING ITEM FROM A FLOW SHEET

 +1        SET DIR(0)="LO^1:"_BDMJ

 +2        SET DIR("A")="Whick Flow Sheet Component(s)"

 +3        WRITE !

 +4        DO DIR^BDMDIC

 +5        IF Y<1

               SET BDMQUIT=""

               QUIT 

 +6        SET BDMY=Y

 +7        QUIT 

BACK      ;EP;SETUP FOR RETURN TO LISTMAN

 +1        SET VALMBCK="R"

 +2        IF BDMGO="FS"

               DO FSINIT

 +3        IF BDMGO="FSC"

               DO FSCINIT

 +4        IF BDMGO="FSM"

               DO MEMINIT

 +5        DO TERM^VALM0

 +6        QUIT 

MEMBERS   ;EP;TO SPECIFY THE MEMBERS FOR A FLOW SHEET COMPONENT

 +1        DO FSCSEL

 +2        IF $DATA(BDMQUIT)

               KILL BDMQUIT

               DO FSCBACK

               QUIT 

 +3        FOR BDMI=1:1

               SET BDMX=$PIECE(BDMY,",",BDMI)

               IF BDMX=""!$DATA(BDMQUIT)

                   QUIT 

               Begin DoDot:1

 +4                IF '$DATA(BDMJ(BDMSDA,BDMX))

                       QUIT 

 +5                SET BDMCDA=+BDMJ(BDMSDA,BDMX)

 +6                IF 'BDMCDA

                       QUIT 

 +7                SET BDMTYPE=$GET(^APCHSFLI(+$PIECE($GET(^APCHSFLC(+BDMSDA,1,+BDMCDA,0)),U,2),0))

 +8                DO MEMDISP

               End DoDot:1

 +9        QUIT 

MEMSEL    ;SELECT THE MEMBER OF THE COMPONENT TO EDIT OR DELETE

 +1        SET DIR(0)="LO^1:"_BDMJ

 +2        SET DIR("A")="Whick Component Members(s)"

 +3        WRITE !

 +4        DO DIR^BDMDIC

 +5        IF Y<1

               SET BDMQUIT=""

               QUIT 

 +6        SET BDMY=Y

 +7        QUIT 

MEMADD    ;EP;TO ADD MEMBERS TO A FLOW SHEET COMPONENT

 +1        SET BDMTYPE=$GET(^APCHSFLI(+$PIECE($GET(^APCHSFLC(+BDMSDA,1,+BDMCDA,0)),U,2),0))

 +2        FOR 

               DO MADD1

               IF $DATA(BDMQUIT)

                   QUIT 

 +3        KILL BDMQUIT

 +4        DO MBACK

 +5        QUIT 

MADD1      WRITE @IOF

 +1        WRITE !?5,"Select"

 +2        WRITE !?5,$PIECE(BDMTYPE,U),?25,"to add to the"

 +3        WRITE !?5,$PIECE(BDMTYPE,U),?25,"component of the "

 +4        WRITE !?5,BDMSNAM,?25,"Flow Sheet"

 +5        SET DIC=+$PIECE(BDMTYPE,U,2)

 +6        IF 'DIC

               SET BDMQUIT=""

               QUIT 

 +7        SET DIC=^DIC(DIC,0,"GL")

 +8        IF DIC=""

               SET BDMQUIT=""

               QUIT 

 +9        SET BDMDIC=DIC

 +10       SET DIC(0)="AEMQZ"

 +11       SET DIC("A")="Which "_$PIECE(BDMTYPE,U)_": "

 +12       WRITE !

 +13       DO DIC^BDMDIC

 +14       IF +Y<1

               SET BDMQUIT=""

               QUIT 

 +15       SET X=+Y_";"_$EXTRACT(BDMDIC,2,99)

 +16       SET $PIECE(^APCHSFLC(BDMSDA,1,BDMCDA,2,0),U,2)="9001020.15AV"

 +17       SET DA(2)=BDMSDA

 +18       SET DA(1)=BDMCDA

 +19       SET DIC="^APCHSFLC("_BDMSDA_",1,"_BDMCDA_",2,"

 +20       SET DIC(0)="L"

 +21       DO FILE^BDMDIC

 +22       QUIT 

MEMDEL    ;EP;TO DELETE MEMBERS FROM A FLOW SHEET COMPONENT

 +1        NEW BDMY

 +2        DO MEMSEL

 +3        IF $DATA(BDMQUIT)

               KILL BDMQUIT

               DO MBACK

               QUIT 

 +4        FOR BDMI=1:1

               SET BDMX=$PIECE(BDMY,",",BDMI)