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
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)
IF BDMX=""
QUIT
Begin DoDot:1
+5 IF '$DATA(BDMJ(BDMSDA,BDMCDA,BDMX))
QUIT
+6 SET DA=+BDMJ(BDMSDA,BDMCDA,BDMX)
+7 SET DA(2)=BDMSDA
+8 SET DA(1)=BDMCDA
+9 SET DIK="^APCHSFLC("_DA(2)_",1,"_DA(1)_",2,"
+10 DO DIK^BDMDIC
End DoDot:1
MBACK SET BDMGO="FSM"
+1 DO BACK
+2 QUIT
DELETE ;EP;TO DELETE FLOW SHEET COMPONENT
+1 QUIT
MEMDISP ;DISPLAY MEMBERS OF A COMPONENT
+1 DO VALM("BDM FLOW SHEET MEMBERS")
+2 QUIT
MEMINIT ;EP;TO LIST ITEMS ON FLOW SHEET
+1 KILL ^TMP("BDMVR",$JOB),BDMJ
+2 SET VALMCNT=0
+3 SET X=" "_$PIECE(BDMTYPE,U)
+4 DO Z(X)
+5 SET X=" ---------------------------"
+6 DO Z(X)
+7 NEW A,B,X,Y
+8 SET BDMMDA=0
+9 FOR
SET BDMMDA=$ORDER(^APCHSFLC(BDMSDA,1,BDMCDA,2,BDMMDA))
IF 'BDMMDA
QUIT
Begin DoDot:1
+10 SET X=$GET(^APCHSFLC(BDMSDA,1,BDMCDA,2,BDMMDA,0))
+11 IF X=""
QUIT
+12 SET BDMGL=U_$PIECE(X,";",2)
+13 IF $EXTRACT(BDMGL,$LENGTH(BDMGL))="("
SET BDMGL=$EXTRACT(BDMGL,1,$LENGTH(BDMGL)-1)
+14 IF $EXTRACT(BDMGL,$LENGTH(BDMGL))=","
SET BDMGL=$EXTRACT(BDMGL,1,$LENGTH(BDMGL)-1)_")"
+15 SET BDMDA=+X
+16 SET X=$PIECE($GET(@BDMGL@(+X,0)),U,$SELECT(BDMGL'["AUTTMSR":1,1:2))
+17 SET A=" "_(VALMCNT-1)
+18 IF $LENGTH(A)=6
SET A=A_" "
+19 SET A=A_" "
+20 SET A=A_X
+21 SET X=A
+22 DO Z(X)
+23 SET BDMJ(BDMSDA,BDMCDA,VALMCNT-2)=BDMMDA_U_A
End DoDot:1
+24 SET BDMJ=VALMCNT-2
+25 QUIT
MEMLIST ;LIST MEMBERS OF EACH COMPONENT FOR DISPLAY WITH COMPONENTS
+1 NEW J,X,Y,BDMX,BDMMDA
+2 SET (J,BDMMDA)=0
+3 FOR
SET BDMMDA=$ORDER(^APCHSFLC(BDMSDA,1,BDMCDA,2,BDMMDA))
IF 'BDMMDA
QUIT
Begin DoDot:1
+4 SET X=$GET(^APCHSFLC(BDMSDA,1,BDMCDA,2,BDMMDA,0))
+5 IF X=""
QUIT
+6 SET J=J+1
+7 SET BDMGL=U_$PIECE(X,";",2)
+8 IF $EXTRACT(BDMGL,$LENGTH(BDMGL))="("
SET BDMGL=$EXTRACT(BDMGL,1,$LENGTH(BDMGL)-1)
+9 IF $EXTRACT(BDMGL,$LENGTH(BDMGL))=","
SET BDMGL=$EXTRACT(BDMGL,1,$LENGTH(BDMGL)-1)_")"
+10 SET X=$PIECE($GET(@BDMGL@(+X,0)),U,$SELECT(BDMGL'["AUTTMSR":1,1:2))
+11 SET A=" "_X
+12 SET X=A
+13 DO Z(X)
End DoDot:1
+14 QUIT
+1 SET VALMSG="- Prev Screen QU Quit ?? More Actions"
+2 QUIT
Z(X) ;SET TMP GLOBAL
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("BDMVR",$JOB,VALMCNT,0)=X
+3 QUIT
