APCLFS ; IHS/CMI/LAB - DMS FLOW SHEET MANAGEMENT UTILITY ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;UTILITY PROGRAM TO MANAGE FLOW SHEET CREATION AND EDITING
FS ;EP;FLOW SHEET MANAGEMENT
S IOP="HOME"
D ^%ZIS
D FS1 Q:$D(APCLQUIT)!$D(APCLOUT)
FSEXIT K APCLQUIT,APCLOUT,APCLJ,APCLX,APCLY,APCLSDA,APCLSNAM,APCLCINK,APCLCNK0,APCLCDA,APCLWHCH,APCLADA,APCLANAM,APCLSF,APCLCANN,APCLGO
K ^TMP("APCLVR",$J)
Q
FS1 D FSEXIT
D FSDISP
Q
FSDISP ;DISPLAY FLOW SHEET
D VALM("APCL 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^APCLDIC
I Y="" S APCLQUIT="" D TABACK Q
I X="^" S APCLQUIT="" D TABACK Q
S (X,APCLSNAM)=Y
S DIC="^APCHSFLC("
S DIC(0)="L"
D FILE^APCLDIC
S APCLSDA=+Y
I 'APCLSDA D TABACK Q
D FSCEDIT
D FSCLIST
TABACK S APCLGO="FS"
D BACK
Q
FSEDIT ;EP;EDIT AN EXISTING FLOW SHEET
D SELECT
I $D(APCLQUIT) K APCLQUIT D TEBACK Q
D FSCLIST
TEBACK S APCLGO="FS"
D BACK
Q
SELECT ;SELECT AN EXISTING FLOW SHEET
S DIR(0)="NO^1:"_APCLJ
S DIR("A")="Which Flow Sheet"
W !
D DIR^APCLDIC
I Y<1 S APCLQUIT="" Q
Q:'$D(APCLJ(Y))
S APCLSDA=+APCLJ(Y)
S APCLSNAM=$P(APCLJ(Y),U,2)
D FSCLIST
Q
FSCEDIT ;EP;EDIT A FLOW SHEET COMPONENT
S DA=APCLSDA
S DIE="^APCHSFLC("
S DR="[APCL FLOW SHEET COMPONENT]"
D DDS^APCLDIC
S APCLGO="FSC"
D BACK
Q
FSINIT ;EP;INITIALIZE ARRAY FOR FLOW SHEET DISPLAY
K ^TMP("APCLVR",$J),APCLJ
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 APCLJ(I)=Y_U_X
I '$D(^TMP("APCLVR",$J)) D
.S VALMCNT=2
.S X="NO FLOW SHEET ON FILE FOR "_APCLX
.D Z(X)
S APCLJ=I
Q
VALM(APCLX) ;VALM INTERFACE
S VALMCC=1 ;1=screen mode, 0=scrolling mode
D TERM^VALM0
D EN^VALM(APCLX)
D CLEAR^VALM1
Q
FSCLIST ;EP;TO DISPLAY ITEMS ON FLOW SHEET LIST
D VALM("APCL FLOW SHEET COMPONENT LIST")
Q
FSCINIT ;EP;TO LIST ITEMS ON FLOW SHEET
N A,B,J,X,Y,Z,APCLTYPE,APCLABEL
K ^TMP("APCLVR",$J),APCLJ,APCLCS
S VALMCNT=0
S X=" "_APCLSNAM
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,APCLX)=0
F S APCLX=$O(^APCHSFLC(APCLSDA,1,"B",APCLX)) Q:'APCLX D
.S APCLCDA=0
.F S APCLCDA=$O(^APCHSFLC(APCLSDA,1,"B",APCLX,APCLCDA)) Q:'APCLCDA D
..S X=$G(^APCHSFLC(APCLSDA,1,APCLCDA,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 APCLTYPE=$P($G(^APCHSFLI(+$P(X,U,2),0)),U)
..S APCLTYPE=APCLTYPE_$E(" ",1,20-$L(APCLTYPE))
..S A=A_APCLTYPE
..S A=A_" "
..S APCLABEL=$P(X,U,3)
..S APCLABEL=APCLABEL_$E(" ",1,20-$L(APCLABEL))
..S A=A_APCLABEL
..S A=A_" "
..S APCLWDTH=$P(X,U,4)
..S A=A_APCLWDTH
..S X=A
..D Z(X)
..S APCLJ(APCLSDA,J)=APCLCDA_U_A
..D MEMLIST
S APCLJ=J
Q
FSCADD ;EP;TO ADD ITEM TO FLOW SHEET
K APCL
N X,Y
I APCLANAM="DIAGNOSIS"!(APCLSNAM="PROBLEM LIST DIAGNOSIS") D I 1
.S X=0
.F S X=$O(^APCHSFLC(APCLSDA,1,X)) Q:'X D
..S Y=$G(^APCHSFLC(APCLSDA,1,X,0))
..S:$P(Y,U)]"" APCL(X)=$P(Y,U)_U_$S($P(Y,U,2)]"":$P(Y,U,2),1:$P(Y,U))
.D ^APCLFS1
.Q:$D(APCLQUIT)
.S X=$P(APCL("LOW"),U)
E D
.D CLEAR^VALM1
.W !?5,"Select an item to ADD to the"
.W !!?5,APCLSNAM," Flow Sheet"
.S DIC=APCLSF
.S DIC(0)="AEMQZ"
.S DIC("A")="Which "_APCLANAM_": "
.W !
.D DIC^APCLDIC
.I +Y<1 S APCLQUIT="" Q
.S APCL("LOW")=+Y
.D X
.S APCL("HIGH")=""
I $D(APCLQUIT) D FSCBACK Q
S DA(1)=APCLSDA
S DIC="^APCHSFLC("_APCLSDA_",1,"
S DIC(0)="L"
S DIC("DR")=".02////"_APCL("HIGH")
D FILE^APCLDIC:'$D(^APCHSFLC(APCLSDA,1,"B",X))
FSCBACK ;EP;S APCLGO="FSC"
D BACK
Q
X ;EVALUATE X FOR PROPER INTERNAL VALUE
I APCLANAM="ADA CODE" S X=Y(0,0)
I APCLANAM="RX" S X=+Y
I APCLANAM="PROCEDURE (MEDICAL)" S X=Y(0,0)
I APCLANAM="PATIENT ED TOPIC" S X=+Y
I APCLANAM="HEALTH FACTORS" S X=+Y
I APCLANAM="PROBLEM LIST DIAGNOSIS" S X=Y(0,0)
Q
FSCDEL ;EP;TO DELETE ITEM FROM FLOW SHEET
D FSCSEL
I $D(APCLQUIT) K APCLQUIT D FSCBACK Q
N APCLI,APCLX
F APCLI=1:1 S APCLX=$P(APCLY,",",APCLI) Q:APCLX="" D
.Q:'$D(APCLJ(APCLSDA,APCLX))
.S APCLCDA=+APCLJ(APCLSDA,APCLX)
.S DA(1)=APCLSDA
.S DA=APCLCDA
.S DIK="^APCHSFLC("_DA(1)_",1,"
.D DIK^APCLDIC
S APCLGO="FSC"
D BACK
Q
FSCSEL ;EP;SELECT EXISTING ITEM FROM A FLOW SHEET
S DIR(0)="LO^1:"_APCLJ
S DIR("A")="Whick Flow Sheet Component(s)"
W !
D DIR^APCLDIC
I Y<1 S APCLQUIT="" Q
S APCLY=Y
Q
BACK ;EP;SETUP FOR RETURN TO LISTMAN
S VALMBCK="R"
D FSINIT:APCLGO="FS"
D FSCINIT:APCLGO="FSC"
D MEMINIT:APCLGO="FSM"
D TERM^VALM0
Q
MEMBERS ;EP;TO SPECIFY THE MEMBERS FOR A FLOW SHEET COMPONENT
D FSCSEL
I $D(APCLQUIT) K APCLQUIT D FSCBACK Q
F APCLI=1:1 S APCLX=$P(APCLY,",",APCLI) Q:APCLX=""!$D(APCLQUIT) D
.Q:'$D(APCLJ(APCLSDA,APCLX))
.S APCLCDA=+APCLJ(APCLSDA,APCLX)
.Q:'APCLCDA
.S APCLTYPE=$G(^APCHSFLI(+$P($G(^APCHSFLC(+APCLSDA,1,+APCLCDA,0)),U,2),0))
.D MEMDISP
Q
MEMSEL ;SELECT THE MEMBER OF THE COMPONENT TO EDIT OR DELETE
S DIR(0)="LO^1:"_APCLJ
S DIR("A")="Whick Component Members(s)"
W !
D DIR^APCLDIC
I Y<1 S APCLQUIT="" Q
S APCLY=Y
Q
MEMADD ;EP;TO ADD MEMBERS TO A FLOW SHEET COMPONENT
S APCLTYPE=$G(^APCHSFLI(+$P($G(^APCHSFLC(+APCLSDA,1,+APCLCDA,0)),U,2),0))
F D MADD1 Q:$D(APCLQUIT)
K APCLQUIT
D MBACK
Q
MADD1 W @IOF
W !?5,"Select"
W !?5,$P(APCLTYPE,U),?25,"to add to the"
W !?5,$P(APCLTYPE,U),?25,"component of the "
W !?5,APCLSNAM,?25,"Flow Sheet"
S DIC=+$P(APCLTYPE,U,2)
I 'DIC S APCLQUIT="" Q
S DIC=^DIC(DIC,0,"GL")
I DIC="" S APCLQUIT="" Q
S APCLDIC=DIC
S DIC(0)="AEMQZ"
S DIC("A")="Which "_$P(APCLTYPE,U)_": "
W !
D DIC^APCLDIC
I +Y<1 S APCLQUIT="" Q
S X=+Y_";"_$E(APCLDIC,2,99)
S $P(^APCHSFLC(APCLSDA,1,APCLCDA,2,0),U,2)="9001020.15AV"
S DA(2)=APCLSDA
S DA(1)=APCLCDA
S DIC="^APCHSFLC("_APCLSDA_",1,"_APCLCDA_",2,"
S DIC(0)="L"
D FILE^APCLDIC
Q
MEMDEL ;EP;TO DELETE MEMBERS FROM A FLOW SHEET COMPONENT
N APCLY
D MEMSEL
I $D(APCLQUIT) K APCLQUIT D MBACK Q
F APCLI=1:1 S APCLX=$P(APCLY,",",APCLI) Q:APCLX="" D
.Q:'$D(APCLJ(APCLSDA,APCLCDA,APCLX))
.S DA=+APCLJ(APCLSDA,APCLCDA,APCLX)
.S DA(2)=APCLSDA
.S DA(1)=APCLCDA
.S DIK="^APCHSFLC("_DA(2)_",1,"_DA(1)_",2,"
.D DIK^APCLDIC
MBACK S APCLGO="FSM"
D BACK
Q
DELETE ;EP;TO DELETE FLOW SHEET COMPONENT
Q
MEMDISP ;DISPLAY MEMBERS OF A COMPONENT
D VALM("APCL FLOW SHEET MEMBERS")
Q
MEMINIT ;EP;TO LIST ITEMS ON FLOW SHEET
K ^TMP("APCLVR",$J),APCLJ
S VALMCNT=0
S X=" "_$P(APCLTYPE,U)
D Z(X)
S X=" ---------------------------"
D Z(X)
N A,B,X,Y
S APCLMDA=0
F S APCLMDA=$O(^APCHSFLC(APCLSDA,1,APCLCDA,2,APCLMDA)) Q:'APCLMDA D
.S X=$G(^APCHSFLC(APCLSDA,1,APCLCDA,2,APCLMDA,0))
.Q:X=""
.S APCLGL=U_$P(X,";",2)
.S:$E(APCLGL,$L(APCLGL))="(" APCLGL=$E(APCLGL,1,$L(APCLGL)-1)
.S:$E(APCLGL,$L(APCLGL))="," APCLGL=$E(APCLGL,1,$L(APCLGL)-1)_")"
.S APCLDA=+X
.S X=$P($G(@APCLGL@(+X,0)),U,$S(APCLGL'["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 APCLJ(APCLSDA,APCLCDA,VALMCNT-2)=APCLMDA_U_A
S APCLJ=VALMCNT-2
Q
MEMLIST ;LIST MEMBERS OF EACH COMPONENT FOR DISPLAY WITH COMPONENTS
N J,X,Y,APCLX,APCLMDA
S (J,APCLMDA)=0
F S APCLMDA=$O(^APCHSFLC(APCLSDA,1,APCLCDA,2,APCLMDA)) Q:'APCLMDA D
.S X=$G(^APCHSFLC(APCLSDA,1,APCLCDA,2,APCLMDA,0))
.Q:X=""
.S J=J+1
.S APCLGL=U_$P(X,";",2)
.S:$E(APCLGL,$L(APCLGL))="(" APCLGL=$E(APCLGL,1,$L(APCLGL)-1)
.S:$E(APCLGL,$L(APCLGL))="," APCLGL=$E(APCLGL,1,$L(APCLGL)-1)_")"
.S X=$P($G(@APCLGL@(+X,0)),U,$S(APCLGL'["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("APCLVR",$J,VALMCNT,0)=X
Q
APCLFS ; IHS/CMI/LAB - DMS FLOW SHEET MANAGEMENT UTILITY ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+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(APCLQUIT)!$DATA(APCLOUT)
QUIT
FSEXIT KILL APCLQUIT,APCLOUT,APCLJ,APCLX,APCLY,APCLSDA,APCLSNAM,APCLCINK,APCLCNK0,APCLCDA,APCLWHCH,APCLADA,APCLANAM,APCLSF,APCLCANN,APCLGO
+1 KILL ^TMP("APCLVR",$JOB)
+2 QUIT
FS1 DO FSEXIT
+1 DO FSDISP
+2 QUIT
FSDISP ;DISPLAY FLOW SHEET
+1 DO VALM("APCL 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^APCLDIC
+5 IF Y=""
SET APCLQUIT=""
DO TABACK
QUIT
+6 IF X="^"
SET APCLQUIT=""
DO TABACK
QUIT
+7 SET (X,APCLSNAM)=Y
+8 SET DIC="^APCHSFLC("
+9 SET DIC(0)="L"
+10 DO FILE^APCLDIC
+11 SET APCLSDA=+Y
+12 IF 'APCLSDA
DO TABACK
QUIT
+13 DO FSCEDIT
+14 DO FSCLIST
TABACK SET APCLGO="FS"
+1 DO BACK
+2 QUIT
FSEDIT ;EP;EDIT AN EXISTING FLOW SHEET
+1 DO SELECT
+2 IF $DATA(APCLQUIT)
KILL APCLQUIT
DO TEBACK
QUIT
+3 DO FSCLIST
TEBACK SET APCLGO="FS"
+1 DO BACK
+2 QUIT
SELECT ;SELECT AN EXISTING FLOW SHEET
+1 SET DIR(0)="NO^1:"_APCLJ
+2 SET DIR("A")="Which Flow Sheet"
+3 WRITE !
+4 DO DIR^APCLDIC
+5 IF Y<1
SET APCLQUIT=""
QUIT
+6 IF '$DATA(APCLJ(Y))
QUIT
+7 SET APCLSDA=+APCLJ(Y)
+8 SET APCLSNAM=$PIECE(APCLJ(Y),U,2)
+9 DO FSCLIST
+10 QUIT
FSCEDIT ;EP;EDIT A FLOW SHEET COMPONENT
+1 SET DA=APCLSDA
+2 SET DIE="^APCHSFLC("
+3 SET DR="[APCL FLOW SHEET COMPONENT]"
+4 DO DDS^APCLDIC
+5 SET APCLGO="FSC"
+6 DO BACK
+7 QUIT
FSINIT ;EP;INITIALIZE ARRAY FOR FLOW SHEET DISPLAY
+1 KILL ^TMP("APCLVR",$JOB),APCLJ
+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 APCLJ(I)=Y_U_X
End DoDot:2
End DoDot:1
+19 IF '$DATA(^TMP("APCLVR",$JOB))
Begin DoDot:1
+20 SET VALMCNT=2
+21 SET X="NO FLOW SHEET ON FILE FOR "_APCLX
+22 DO Z(X)
End DoDot:1
+23 SET APCLJ=I
+24 QUIT
VALM(APCLX) ;VALM INTERFACE
+1 ;1=screen mode, 0=scrolling mode
SET VALMCC=1
+2 DO TERM^VALM0
+3 DO EN^VALM(APCLX)
+4 DO CLEAR^VALM1
+5 QUIT
FSCLIST ;EP;TO DISPLAY ITEMS ON FLOW SHEET LIST
+1 DO VALM("APCL FLOW SHEET COMPONENT LIST")
+2 QUIT
FSCINIT ;EP;TO LIST ITEMS ON FLOW SHEET
+1 NEW A,B,J,X,Y,Z,APCLTYPE,APCLABEL
+2 KILL ^TMP("APCLVR",$JOB),APCLJ,APCLCS
+3 SET VALMCNT=0
+4 SET X=" "_APCLSNAM
+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,APCLX)=0
+15 FOR
SET APCLX=$ORDER(^APCHSFLC(APCLSDA,1,"B",APCLX))
IF 'APCLX
QUIT
Begin DoDot:1
+16 SET APCLCDA=0
+17 FOR
SET APCLCDA=$ORDER(^APCHSFLC(APCLSDA,1,"B",APCLX,APCLCDA))
IF 'APCLCDA
QUIT
Begin DoDot:2
+18 SET X=$GET(^APCHSFLC(APCLSDA,1,APCLCDA,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 APCLTYPE=$PIECE($GET(^APCHSFLI(+$PIECE(X,U,2),0)),U)
+28 SET APCLTYPE=APCLTYPE_$EXTRACT(" ",1,20-$LENGTH(APCLTYPE))
+29 SET A=A_APCLTYPE
+30 SET A=A_" "
+31 SET APCLABEL=$PIECE(X,U,3)
+32 SET APCLABEL=APCLABEL_$EXTRACT(" ",1,20-$LENGTH(APCLABEL))
+33 SET A=A_APCLABEL
+34 SET A=A_" "
+35 SET APCLWDTH=$PIECE(X,U,4)
+36 SET A=A_APCLWDTH
+37 SET X=A
+38 DO Z(X)
+39 SET APCLJ(APCLSDA,J)=APCLCDA_U_A
+40 DO MEMLIST
End DoDot:2
End DoDot:1
+41 SET APCLJ=J
+42 QUIT
FSCADD ;EP;TO ADD ITEM TO FLOW SHEET
+1 KILL APCL
+2 NEW X,Y
+3 IF APCLANAM="DIAGNOSIS"!(APCLSNAM="PROBLEM LIST DIAGNOSIS")
Begin DoDot:1
+4 SET X=0
+5 FOR
SET X=$ORDER(^APCHSFLC(APCLSDA,1,X))
IF 'X
QUIT
Begin DoDot:2
+6 SET Y=$GET(^APCHSFLC(APCLSDA,1,X,0))
+7 IF $PIECE(Y,U)]""
SET APCL(X)=$PIECE(Y,U)_U_$SELECT($PIECE(Y,U,2)]"":$PIECE(Y,U,2),1:$PIECE(Y,U))
End DoDot:2
+8 DO ^APCLFS1
+9 IF $DATA(APCLQUIT)
QUIT
+10 SET X=$PIECE(APCL("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,APCLSNAM," Flow Sheet"
+15 SET DIC=APCLSF
+16 SET DIC(0)="AEMQZ"
+17 SET DIC("A")="Which "_APCLANAM_": "
+18 WRITE !
+19 DO DIC^APCLDIC
+20 IF +Y<1
SET APCLQUIT=""
QUIT
+21 SET APCL("LOW")=+Y
+22 DO X
+23 SET APCL("HIGH")=""
End DoDot:1
+24 IF $DATA(APCLQUIT)
DO FSCBACK
QUIT
+25 SET DA(1)=APCLSDA
+26 SET DIC="^APCHSFLC("_APCLSDA_",1,"
+27 SET DIC(0)="L"
+28 SET DIC("DR")=".02////"_APCL("HIGH")
+29 IF '$DATA(^APCHSFLC(APCLSDA,1,"B",X))
DO FILE^APCLDIC
FSCBACK ;EP;S APCLGO="FSC"
+1 DO BACK
+2 QUIT
X ;EVALUATE X FOR PROPER INTERNAL VALUE
+1 IF APCLANAM="ADA CODE"
SET X=Y(0,0)
+2 IF APCLANAM="RX"
SET X=+Y
+3 IF APCLANAM="PROCEDURE (MEDICAL)"
SET X=Y(0,0)
+4 IF APCLANAM="PATIENT ED TOPIC"
SET X=+Y
+5 IF APCLANAM="HEALTH FACTORS"
SET X=+Y
+6 IF APCLANAM="PROBLEM LIST DIAGNOSIS"
SET X=Y(0,0)
+7 QUIT
FSCDEL ;EP;TO DELETE ITEM FROM FLOW SHEET
+1 DO FSCSEL
+2 IF $DATA(APCLQUIT)
KILL APCLQUIT
DO FSCBACK
QUIT
+3 NEW APCLI,APCLX
+4 FOR APCLI=1:1
SET APCLX=$PIECE(APCLY,",",APCLI)
IF APCLX=""
QUIT
Begin DoDot:1
+5 IF '$DATA(APCLJ(APCLSDA,APCLX))
QUIT
+6 SET APCLCDA=+APCLJ(APCLSDA,APCLX)
+7 SET DA(1)=APCLSDA
+8 SET DA=APCLCDA
+9 SET DIK="^APCHSFLC("_DA(1)_",1,"
+10 DO DIK^APCLDIC
End DoDot:1
+11 SET APCLGO="FSC"
+12 DO BACK
+13 QUIT
FSCSEL ;EP;SELECT EXISTING ITEM FROM A FLOW SHEET
+1 SET DIR(0)="LO^1:"_APCLJ
+2 SET DIR("A")="Whick Flow Sheet Component(s)"
+3 WRITE !
+4 DO DIR^APCLDIC
+5 IF Y<1
SET APCLQUIT=""
QUIT
+6 SET APCLY=Y
+7 QUIT
BACK ;EP;SETUP FOR RETURN TO LISTMAN
+1 SET VALMBCK="R"
+2 IF APCLGO="FS"
DO FSINIT
+3 IF APCLGO="FSC"
DO FSCINIT
+4 IF APCLGO="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(APCLQUIT)
KILL APCLQUIT
DO FSCBACK
QUIT
+3 FOR APCLI=1:1
SET APCLX=$PIECE(APCLY,",",APCLI)
IF APCLX=""!$DATA(APCLQUIT)
QUIT
Begin DoDot:1
+4 IF '$DATA(APCLJ(APCLSDA,APCLX))
QUIT
+5 SET APCLCDA=+APCLJ(APCLSDA,APCLX)
+6 IF 'APCLCDA
QUIT
+7 SET APCLTYPE=$GET(^APCHSFLI(+$PIECE($GET(^APCHSFLC(+APCLSDA,1,+APCLCDA,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:"_APCLJ
+2 SET DIR("A")="Whick Component Members(s)"
+3 WRITE !
+4 DO DIR^APCLDIC
+5 IF Y<1
SET APCLQUIT=""
QUIT
+6 SET APCLY=Y
+7 QUIT
MEMADD ;EP;TO ADD MEMBERS TO A FLOW SHEET COMPONENT
+1 SET APCLTYPE=$GET(^APCHSFLI(+$PIECE($GET(^APCHSFLC(+APCLSDA,1,+APCLCDA,0)),U,2),0))
+2 FOR
DO MADD1
IF $DATA(APCLQUIT)
QUIT
+3 KILL APCLQUIT
+4 DO MBACK
+5 QUIT
MADD1 WRITE @IOF
+1 WRITE !?5,"Select"
+2 WRITE !?5,$PIECE(APCLTYPE,U),?25,"to add to the"
+3 WRITE !?5,$PIECE(APCLTYPE,U),?25,"component of the "
+4 WRITE !?5,APCLSNAM,?25,"Flow Sheet"
+5 SET DIC=+$PIECE(APCLTYPE,U,2)
+6 IF 'DIC
SET APCLQUIT=""
QUIT
+7 SET DIC=^DIC(DIC,0,"GL")
+8 IF DIC=""
SET APCLQUIT=""
QUIT
+9 SET APCLDIC=DIC
+10 SET DIC(0)="AEMQZ"
+11 SET DIC("A")="Which "_$PIECE(APCLTYPE,U)_": "
+12 WRITE !
+13 DO DIC^APCLDIC
+14 IF +Y<1
SET APCLQUIT=""
QUIT
+15 SET X=+Y_";"_$EXTRACT(APCLDIC,2,99)
+16 SET $PIECE(^APCHSFLC(APCLSDA,1,APCLCDA,2,0),U,2)="9001020.15AV"
+17 SET DA(2)=APCLSDA
+18 SET DA(1)=APCLCDA
+19 SET DIC="^APCHSFLC("_APCLSDA_",1,"_APCLCDA_",2,"
+20 SET DIC(0)="L"
+21 DO FILE^APCLDIC
+22 QUIT
MEMDEL ;EP;TO DELETE MEMBERS FROM A FLOW SHEET COMPONENT
+1 NEW APCLY
+2 DO MEMSEL
+3 IF $DATA(APCLQUIT)
KILL APCLQUIT
DO MBACK
QUIT
+4 FOR APCLI=1:1
SET APCLX=$PIECE(APCLY,",",APCLI)
IF APCLX=""
QUIT
Begin DoDot:1
+5 IF '$DATA(APCLJ(APCLSDA,APCLCDA,APCLX))
QUIT
+6 SET DA=+APCLJ(APCLSDA,APCLCDA,APCLX)
+7 SET DA(2)=APCLSDA
+8 SET DA(1)=APCLCDA
+9 SET DIK="^APCHSFLC("_DA(2)_",1,"_DA(1)_",2,"
+10 DO DIK^APCLDIC
End DoDot:1
MBACK SET APCLGO="FSM"
+1 DO BACK
+2 QUIT
DELETE ;EP;TO DELETE FLOW SHEET COMPONENT
+1 QUIT
MEMDISP ;DISPLAY MEMBERS OF A COMPONENT
+1 DO VALM("APCL FLOW SHEET MEMBERS")
+2 QUIT
MEMINIT ;EP;TO LIST ITEMS ON FLOW SHEET
+1 KILL ^TMP("APCLVR",$JOB),APCLJ
+2 SET VALMCNT=0
+3 SET X=" "_$PIECE(APCLTYPE,U)
+4 DO Z(X)
+5 SET X=" ---------------------------"
+6 DO Z(X)
+7 NEW A,B,X,Y
+8 SET APCLMDA=0
+9 FOR
SET APCLMDA=$ORDER(^APCHSFLC(APCLSDA,1,APCLCDA,2,APCLMDA))
IF 'APCLMDA
QUIT
Begin DoDot:1
+10 SET X=$GET(^APCHSFLC(APCLSDA,1,APCLCDA,2,APCLMDA,0))
+11 IF X=""
QUIT
+12 SET APCLGL=U_$PIECE(X,";",2)
+13 IF $EXTRACT(APCLGL,$LENGTH(APCLGL))="("
SET APCLGL=$EXTRACT(APCLGL,1,$LENGTH(APCLGL)-1)
+14 IF $EXTRACT(APCLGL,$LENGTH(APCLGL))=","
SET APCLGL=$EXTRACT(APCLGL,1,$LENGTH(APCLGL)-1)_")"
+15 SET APCLDA=+X
+16 SET X=$PIECE($GET(@APCLGL@(+X,0)),U,$SELECT(APCLGL'["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 APCLJ(APCLSDA,APCLCDA,VALMCNT-2)=APCLMDA_U_A
End DoDot:1
+24 SET APCLJ=VALMCNT-2
+25 QUIT
MEMLIST ;LIST MEMBERS OF EACH COMPONENT FOR DISPLAY WITH COMPONENTS
+1 NEW J,X,Y,APCLX,APCLMDA
+2 SET (J,APCLMDA)=0
+3 FOR
SET APCLMDA=$ORDER(^APCHSFLC(APCLSDA,1,APCLCDA,2,APCLMDA))
IF 'APCLMDA
QUIT
Begin DoDot:1
+4 SET X=$GET(^APCHSFLC(APCLSDA,1,APCLCDA,2,APCLMDA,0))
+5 IF X=""
QUIT
+6 SET J=J+1
+7 SET APCLGL=U_$PIECE(X,";",2)
+8 IF $EXTRACT(APCLGL,$LENGTH(APCLGL))="("
SET APCLGL=$EXTRACT(APCLGL,1,$LENGTH(APCLGL)-1)
+9 IF $EXTRACT(APCLGL,$LENGTH(APCLGL))=","
SET APCLGL=$EXTRACT(APCLGL,1,$LENGTH(APCLGL)-1)_")"
+10 SET X=$PIECE($GET(@APCLGL@(+X,0)),U,$SELECT(APCLGL'["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("APCLVR",$JOB,VALMCNT,0)=X
+3 QUIT
