APCLFS.m

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

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("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)