BDMFFS ; cmi/anch/maw - DMS FLOW SHEET MANAGEMENT UTILITY ;
;;2.0;DIABETES MANAGEMENT SYSTEM;;AUG 11, 2006
;
;This routine was originally marked as Patch #5
;but is not called from any routine. The protocols
;in this uci were not in Patch 4 so I did not include
;this routine in patch 5 - FASCADD+8 calls non existent
;routine BDMFFS1
;AFTER REVIEW THE ROUTINE IS NOW INCLUDED IN PATCH #5
;I HAVE SIMPLY COMMENTED OUT THE CALL TO THE NONEXISTENT
;ROUTINE
;
;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,BDMFSDA,BDMFSNAM,BDMCINK,BDMCINK0,BDMCDA,BDMWHICH,BDMADA,BDMANAM,BDMFSF,BDMCANON,BDMGO
K ^TMP("BDMVR",$J)
Q
FS1 D FSEXIT
D FSDISP
Q
D FSHEAD
S DIR(0)="SO^1:Diagnostic/Treatment Flow Sheets;2:Lab Flow Sheets"
S DIR("A")="Which one"
D DIR^BDMFDIC
I Y<1 S BDMQUIT="" Q
S BDMWHICH=$S(Y=1:"RX",1:"LAB")
D FSRX
Q
FSRX ;PROCESS FLOW SHEET
F D FSRX1 Q:$D(BDMQUIT)!$D(BDMOUT)
K BDMQUIT
Q
FSRX1 ;
W @IOF
W !?10,"Select one of the following ",!?10
I BDMWHICH="RX" D
.W "DIAGNOSIS/TREATMENT"
.S DIR(0)="SO^1:Diagnosis;2:ADA Code;3:Medication;4:Procedure (Medical);5:Patient Education Topic;6:Health Factors;7:Problem List Diagnosis"
I BDMWHICH="LAB" D
.W "LAB"
.S DIR(0)="SO^1:Cholesterol;2:Creatinine;3:Glucose;4:HGB A1C;5:Pap Smear;6:Triglycerides;7:Urine Protein;8:Urinalysis"
S DIR("A")="Which one"
W " Flow Sheets to review."
D DIR^BDMFDIC
I Y<1 S BDMQUIT="" Q
I BDMWHICH="RX" D
.I Y=1 S BDMANAM="DIAGNOSIS"
.I Y=2 S BDMANAM="ADA CODE"
.I Y=3 S BDMANAM="RX"
.I Y=4 S BDMANAM="PROCEDURE (MEDICAL)"
.I Y=5 S BDMANAM="PATIENT ED TOPIC"
.I Y=6 S BDMANAM="HEALTH FACTORS"
.I Y=7 S BDMANAM="PROBLEM LIST DIAGNOSIS"
.S BDMADA=$O(^AMQQ(5,"B",BDMANAM,""))
.I 'BDMADA D Q
..W !!,"A taxonomy can not be created for this attribute. Ask your"
..W !,"system manager to add ",BDMX," as an attribute then try again."
.S BDMCINK=$P(^AMQQ(5,BDMADA,0),U,5)
.S BDMFSF=U_$P(^AMQQ(5,BDMADA,0),U,18)
.S BDMCINK0=$G(^AMQQ(1,BDMCINK,0))
.Q:BDMCINK0=""
.D FSDISP:BDMCINK
I BDMWHICH="LAB" D
.S X=Y(0)
.X ^%ZOSF("UPPERCASE")
.S BDMX=Y
.D LABFS
Q
LABFS ;LAB FLOW SHEET
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^BDMFDIC
I Y="" S BDMQUIT="" D TABACK Q
S (X,BDMFSNAM)=Y
S DIC="^APCHSFLC("
S DIC(0)="L"
D FILE^BDMFDIC
S BDMFSDA=+Y
I 'BDMFSDA 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^BDMFDIC
I Y<1 S BDMQUIT="" Q
Q:'$D(BDMJ(Y))
S BDMFSDA=+BDMJ(Y)
S BDMFSNAM=$P(BDMJ(Y),U,2)
D FSCLIST
Q
FSCEDIT ;EP;EDIT A FLOW SHEET COMPONENT
S DA=BDMFSDA
S DIE="^APCHSFLC("
S DR="[BDM FLOW SHEET COMPONENT]"
D DDS^BDMFDIC
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,BDMLABEL
K ^TMP("BDMVR",$J),BDMJ,BDMCS
S VALMCNT=0
S X=" "_BDMFSNAM
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(BDMFSDA,1,"B",BDMX)) Q:'BDMX D
.S BDMCDA=0
.F S BDMCDA=$O(^APCHSFLC(BDMFSDA,1,"B",BDMX,BDMCDA)) Q:'BDMCDA D
..S X=$G(^APCHSFLC(BDMFSDA,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 BDMLABEL=$P(X,U,3)
..S BDMLABEL=BDMLABEL_$E(" ",1,20-$L(BDMLABEL))
..S A=A_BDMLABEL
..S A=A_" "
..S BDMWIDTH=$P(X,U,4)
..S A=A_BDMWIDTH
..S X=A
..D Z(X)
..S BDMJ(BDMFSDA,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"!(BDMFSNAM="PROBLEM LIST DIAGNOSIS") D I 1
.S X=0
.F S X=$O(^APCHSFLC(BDMFSDA,1,X)) Q:'X D
..S Y=$G(^APCHSFLC(BDMFSDA,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))
.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,BDMFSNAM," Flow Sheet"
.S DIC=BDMFSF
.S DIC(0)="AEMQZ"
.S DIC("A")="Which "_BDMANAM_": "
.W !
.D DIC^BDMFDIC
.I +Y<1 S BDMQUIT="" Q
.S BDM("LOW")=+Y
.D X
.S BDM("HIGH")=""
I $D(BDMQUIT) D FSCBACK Q
S DA(1)=BDMFSDA
S DIC="^APCHSFLC("_BDMFSDA_",1,"
S DIC(0)="L"
S DIC("DR")=".02////"_BDM("HIGH")
D FILE^BDMFDIC:'$D(^APCHSFLC(BDMFSDA,1,"B",X))
FSCBACK 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(BDMFSDA,BDMX))
.S BDMCDA=+BDMJ(BDMFSDA,BDMX)
.S DA(1)=BDMFSDA
.S DA=BDMCDA
.S DIK="^APCHSFLC("_DA(1)_",1,"
.D DIK^BDMFDIC
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^BDMFDIC
I Y<1 S BDMQUIT="" Q
S BDMY=Y
Q
BACK ;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(BDMFSDA,BDMX))
.S BDMCDA=+BDMJ(BDMFSDA,BDMX)
.Q:'BDMCDA
.S BDMTYPE=$G(^APCHSFLI(+$P($G(^APCHSFLC(+BDMFSDA,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^BDMFDIC
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(+BDMFSDA,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,BDMFSNAM,?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^BDMFDIC
I +Y<1 S BDMQUIT="" Q
S X=+Y_";"_$E(BDMDIC,2,99)
S $P(^APCHSFLC(BDMFSDA,1,BDMCDA,2,0),U,2)="9001020.15AV"
S DA(2)=BDMFSDA
S DA(1)=BDMCDA
S DIC="^APCHSFLC("_BDMFSDA_",1,"_BDMCDA_",2,"
S DIC(0)="L"
D FILE^BDMFDIC
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(BDMFSDA,BDMCDA,BDMX))
.S DA=+BDMJ(BDMFSDA,BDMCDA,BDMX)
.S DA(2)=BDMFSDA
.S DA(1)=BDMCDA
.S DIK="^APCHSFLC("_DA(2)_",1,"_DA(1)_",2,"
.D DIK^BDMFDIC
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(BDMFSDA,1,BDMCDA,2,BDMMDA)) Q:'BDMMDA D
.S X=$G(^APCHSFLC(BDMFSDA,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(BDMFSDA,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(BDMFSDA,1,BDMCDA,2,BDMMDA)) Q:'BDMMDA D
.S X=$G(^APCHSFLC(BDMFSDA,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 Q Quit ?? More Actions"
Q
Z(X) ;SET TMP GLOBAL
S VALMCNT=VALMCNT+1
S ^TMP("BDMVR",$J,VALMCNT,0)=X
Q
BDMFFS ; cmi/anch/maw - DMS FLOW SHEET MANAGEMENT UTILITY ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;;AUG 11, 2006
+2 ;
+3 ;This routine was originally marked as Patch #5
+4 ;but is not called from any routine. The protocols
+5 ;in this uci were not in Patch 4 so I did not include
+6 ;this routine in patch 5 - FASCADD+8 calls non existent
+7 ;routine BDMFFS1
+8 ;AFTER REVIEW THE ROUTINE IS NOW INCLUDED IN PATCH #5
+9 ;I HAVE SIMPLY COMMENTED OUT THE CALL TO THE NONEXISTENT
+10 ;ROUTINE
+11 ;
+12 ;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,BDMFSDA,BDMFSNAM,BDMCINK,BDMCINK0,BDMCDA,BDMWHICH,BDMADA,BDMANAM,BDMFSF,BDMCANON,BDMGO
+1 KILL ^TMP("BDMVR",$JOB)
+2 QUIT
FS1 DO FSEXIT
+1 DO FSDISP
+2 QUIT
+3 DO FSHEAD
+4 SET DIR(0)="SO^1:Diagnostic/Treatment Flow Sheets;2:Lab Flow Sheets"
+5 SET DIR("A")="Which one"
+6 DO DIR^BDMFDIC
+7 IF Y<1
SET BDMQUIT=""
QUIT
+8 SET BDMWHICH=$SELECT(Y=1:"RX",1:"LAB")
+9 DO FSRX
+10 QUIT
FSRX ;PROCESS FLOW SHEET
+1 FOR
DO FSRX1
IF $DATA(BDMQUIT)!$DATA(BDMOUT)
QUIT
+2 KILL BDMQUIT
+3 QUIT
FSRX1 ;
+1 WRITE @IOF
+2 WRITE !?10,"Select one of the following ",!?10
+3 IF BDMWHICH="RX"
Begin DoDot:1
+4 WRITE "DIAGNOSIS/TREATMENT"
+5 SET DIR(0)="SO^1:Diagnosis;2:ADA Code;3:Medication;4:Procedure (Medical);5:Patient Education Topic;6:Health Factors;7:Problem List Diagnosis"
End DoDot:1
+6 IF BDMWHICH="LAB"
Begin DoDot:1
+7 WRITE "LAB"
+8 SET DIR(0)="SO^1:Cholesterol;2:Creatinine;3:Glucose;4:HGB A1C;5:Pap Smear;6:Triglycerides;7:Urine Protein;8:Urinalysis"
End DoDot:1
+9 SET DIR("A")="Which one"
+10 WRITE " Flow Sheets to review."
+11 DO DIR^BDMFDIC
+12 IF Y<1
SET BDMQUIT=""
QUIT
+13 IF BDMWHICH="RX"
Begin DoDot:1
+14 IF Y=1
SET BDMANAM="DIAGNOSIS"
+15 IF Y=2
SET BDMANAM="ADA CODE"
+16 IF Y=3
SET BDMANAM="RX"
+17 IF Y=4
SET BDMANAM="PROCEDURE (MEDICAL)"
+18 IF Y=5
SET BDMANAM="PATIENT ED TOPIC"
+19 IF Y=6
SET BDMANAM="HEALTH FACTORS"
+20 IF Y=7
SET BDMANAM="PROBLEM LIST DIAGNOSIS"
+21 SET BDMADA=$ORDER(^AMQQ(5,"B",BDMANAM,""))
+22 IF 'BDMADA
Begin DoDot:2
+23 WRITE !!,"A taxonomy can not be created for this attribute. Ask your"
+24 WRITE !,"system manager to add ",BDMX," as an attribute then try again."
End DoDot:2
QUIT
+25 SET BDMCINK=$PIECE(^AMQQ(5,BDMADA,0),U,5)
+26 SET BDMFSF=U_$PIECE(^AMQQ(5,BDMADA,0),U,18)
+27 SET BDMCINK0=$GET(^AMQQ(1,BDMCINK,0))
+28 IF BDMCINK0=""
QUIT
+29 IF BDMCINK
DO FSDISP
End DoDot:1
+30 IF BDMWHICH="LAB"
Begin DoDot:1
+31 SET X=Y(0)
+32 XECUTE ^%ZOSF("UPPERCASE")
+33 SET BDMX=Y
+34 DO LABFS
End DoDot:1
+35 QUIT
LABFS ;LAB FLOW SHEET
+1 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^BDMFDIC
+5 IF Y=""
SET BDMQUIT=""
DO TABACK
QUIT
+6 SET (X,BDMFSNAM)=Y
+7 SET DIC="^APCHSFLC("
+8 SET DIC(0)="L"
+9 DO FILE^BDMFDIC
+10 SET BDMFSDA=+Y
+11 IF 'BDMFSDA
DO TABACK
QUIT
+12 DO FSCEDIT
+13 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^BDMFDIC
+5 IF Y<1
SET BDMQUIT=""
QUIT
+6 IF '$DATA(BDMJ(Y))
QUIT
+7 SET BDMFSDA=+BDMJ(Y)
+8 SET BDMFSNAM=$PIECE(BDMJ(Y),U,2)
+9 DO FSCLIST
+10 QUIT
FSCEDIT ;EP;EDIT A FLOW SHEET COMPONENT
+1 SET DA=BDMFSDA
+2 SET DIE="^APCHSFLC("
+3 SET DR="[BDM FLOW SHEET COMPONENT]"
+4 DO DDS^BDMFDIC
+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,BDMLABEL
+2 KILL ^TMP("BDMVR",$JOB),BDMJ,BDMCS
+3 SET VALMCNT=0
+4 SET X=" "_BDMFSNAM
+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(BDMFSDA,1,"B",BDMX))
IF 'BDMX
QUIT
Begin DoDot:1
+16 SET BDMCDA=0
+17 FOR
SET BDMCDA=$ORDER(^APCHSFLC(BDMFSDA,1,"B",BDMX,BDMCDA))
IF 'BDMCDA
QUIT
Begin DoDot:2
+18 SET X=$GET(^APCHSFLC(BDMFSDA,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 BDMLABEL=$PIECE(X,U,3)
+32 SET BDMLABEL=BDMLABEL_$EXTRACT(" ",1,20-$LENGTH(BDMLABEL))
+33 SET A=A_BDMLABEL
+34 SET A=A_" "
+35 SET BDMWIDTH=$PIECE(X,U,4)
+36 SET A=A_BDMWIDTH
+37 SET X=A
+38 DO Z(X)
+39 SET BDMJ(BDMFSDA,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"!(BDMFSNAM="PROBLEM LIST DIAGNOSIS")
Begin DoDot:1
+4 SET X=0
+5 FOR
SET X=$ORDER(^APCHSFLC(BDMFSDA,1,X))
IF 'X
QUIT
Begin DoDot:2
+6 SET Y=$GET(^APCHSFLC(BDMFSDA,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 IF $DATA(BDMQUIT)
QUIT
+9 SET X=$PIECE(BDM("LOW"),U)
End DoDot:1
IF 1
+10 IF '$TEST
Begin DoDot:1
+11 DO CLEAR^VALM1
+12 WRITE !?5,"Select an item to ADD to the"
+13 WRITE !!?5,BDMFSNAM," Flow Sheet"
+14 SET DIC=BDMFSF
+15 SET DIC(0)="AEMQZ"
+16 SET DIC("A")="Which "_BDMANAM_": "
+17 WRITE !
+18 DO DIC^BDMFDIC
+19 IF +Y<1
SET BDMQUIT=""
QUIT
+20 SET BDM("LOW")=+Y
+21 DO X
+22 SET BDM("HIGH")=""
End DoDot:1
+23 IF $DATA(BDMQUIT)
DO FSCBACK
QUIT
+24 SET DA(1)=BDMFSDA
+25 SET DIC="^APCHSFLC("_BDMFSDA_",1,"
+26 SET DIC(0)="L"
+27 SET DIC("DR")=".02////"_BDM("HIGH")
+28 IF '$DATA(^APCHSFLC(BDMFSDA,1,"B",X))
DO FILE^BDMFDIC
FSCBACK SET 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(BDMFSDA,BDMX))
QUIT
+6 SET BDMCDA=+BDMJ(BDMFSDA,BDMX)
+7 SET DA(1)=BDMFSDA
+8 SET DA=BDMCDA
+9 SET DIK="^APCHSFLC("_DA(1)_",1,"
+10 DO DIK^BDMFDIC
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^BDMFDIC
+5 IF Y<1
SET BDMQUIT=""
QUIT
+6 SET BDMY=Y
+7 QUIT
BACK ;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(BDMFSDA,BDMX))
QUIT
+5 SET BDMCDA=+BDMJ(BDMFSDA,BDMX)
+6 IF 'BDMCDA
QUIT
+7 SET BDMTYPE=$GET(^APCHSFLI(+$PIECE($GET(^APCHSFLC(+BDMFSDA,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^BDMFDIC
+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(+BDMFSDA,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,BDMFSNAM,?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^BDMFDIC
+14 IF +Y<1
SET BDMQUIT=""
QUIT
+15 SET X=+Y_";"_$EXTRACT(BDMDIC,2,99)
+16 SET $PIECE(^APCHSFLC(BDMFSDA,1,BDMCDA,2,0),U,2)="9001020.15AV"
+17 SET DA(2)=BDMFSDA
+18 SET DA(1)=BDMCDA
+19 SET DIC="^APCHSFLC("_BDMFSDA_",1,"_BDMCDA_",2,"
+20 SET DIC(0)="L"
+21 DO FILE^BDMFDIC
+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(BDMFSDA,BDMCDA,BDMX))
QUIT
+6 SET DA=+BDMJ(BDMFSDA,BDMCDA,BDMX)
+7 SET DA(2)=BDMFSDA
+8 SET DA(1)=BDMCDA
+9 SET DIK="^APCHSFLC("_DA(2)_",1,"_DA(1)_",2,"
+10 DO DIK^BDMFDIC
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(BDMFSDA,1,BDMCDA,2,BDMMDA))
IF 'BDMMDA
QUIT
Begin DoDot:1
+10 SET X=$GET(^APCHSFLC(BDMFSDA,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(BDMFSDA,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(BDMFSDA,1,BDMCDA,2,BDMMDA))
IF 'BDMMDA
QUIT
Begin DoDot:1
+4 SET X=$GET(^APCHSFLC(BDMFSDA,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 Q 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
