APCDPE.m

APCDPE ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 25-JUN-1996 ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;; ;

EN ; -- main entry point for APCD VGEN SELECT ITEMS

 K DIR D ^XBFMK

 D EN^XBVK("APCD")

 D EN^VALM("APCDPE COHORT ENTRY MAIN")

 D CLEAR^VALM1

 D EN^XBVK("AUPN"),^XBFMK

 K APCDLIST,APCDSEL,APCDI,APCDC,APCDCRIT,APCDDISP,APCDHIGH,APCDCUT,APCDANS,VALMHDR,VALMCNT

 I '$D(APCDCSEL) W !!,"No items selected for entry!" Q

 D ^APCDPE1

 D EN^XBVK("APCD"),EN^XBVK("AUPN"),^XBFMK

 K ATXICD

 Q

 ;

HDR ; -- header code

 S VALMHDR(1)="                        "_$G(IORVON)_"PCC ITEM SELECTION MENU"_$G(IORVOFF)

 S VALMHDR(2)="The following data items can be selected to be entered on a PCC Visit."

 S VALMHDR(3)="Choose the items you wish to enter on each PCC Visit."

 Q

 ;

 ;

INIT ; -- init variables and list array

 K APCDDISP,APCDSEL,APCDHIGH,APCDLIST

 S APCDHIGH=0,X=0 F  S X=$O(^APCDTKW("FP",X)) Q:X'=+X  S Y=$O(^APCDTKW("FP",X,"")),APCDHIGH=APCDHIGH+1,APCDSEL(APCDHIGH)=Y

 S APCDCUT=((APCDHIGH/3)+1)\1

 S (C,I)=0,J=1,K=1 F  S I=$O(APCDSEL(I)) Q:I'=+I!($D(APCDDISP(I)))  D

 .S C=C+1,APCDLIST(C,0)=I_") "_$S($D(APCDCSEL(I)):"*",1:" ")_$S($P(^APCDTKW(APCDSEL(I),0),U,12)]"":$E($P(^APCDTKW(APCDSEL(I),0),U,12),1,20),1:$E($P(^APCDTKW(APCDSEL(I),0),U,6),1,20)) S APCDDISP(I)="",APCDLIST("IDX",C,C)=""

 .S J=I+APCDCUT

 .I $D(APCDSEL(J)),'$D(APCDDISP(J)) S $E(APCDLIST(C,0),28)=J_") "_$S($D(APCDCSEL(J)):"*",1:" ")_$S($P(^APCDTKW(APCDSEL(J),0),U,12)]"":$E($P(^APCDTKW(APCDSEL(J),0),U,12),1,20),1:$E($P(^APCDTKW(APCDSEL(J),0),U,6),1,20)) S APCDDISP(J)=""

 .S K=J+APCDCUT

 .I $D(APCDSEL(K)),'$D(APCDDISP(K)) S $E(APCDLIST(C,0),55)=K_") "_$S($D(APCDCSEL(K)):"*",1:" ")_$S($P(^APCDTKW(APCDSEL(K),0),U,12)]"":$E($P(^APCDTKW(APCDSEL(K),0),U,12),1,20),1:$E($P(^APCDTKW(APCDSEL(K),0),U,6),1,20)) S APCDDISP(K)=""

 K APCDDISP

 S VALMCNT=C

 Q

 ;

ADD ;EP - add an item to the selected list - called from a protocol

 W ! S DIR(0)="LO^1:"_APCDHIGH,DIR("A")="Which item(s)" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I Y="" W !,"No items selected." G ADDX

 I $D(DIRUT) W !,"No items selected." G ADDX

 F APCDI=1:1 S APCDC=$P(Y,",",APCDI) Q:APCDC=""  S X=APCDSEL(APCDC),APCDCSEL(APCDC)=X

 D FULL^VALM1 W:$D(IOF) @IOF

ADDX ;

 D BACK

 Q

REM ;EP - remove a selected item - called from protocol entry

 I '$D(APCDCSEL) W !!,"No items have been selected.",! H 2 G REMX

 S DIR(0)="LO^:",DIR("A")="Remove which selected item" K DA D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I Y="" W !,"No items selected." G REMX

 I $D(DIRUT) W !,"No items selected." G REMX

 S APCDANS=Y,APCDC="" F APCDI=1:1 S APCDC=$P(APCDANS,",",APCDI) Q:APCDC=""  S APCDCRIT=APCDSEL(APCDC) D

 .I '$D(APCDCSEL(APCDC)) W !,"Item ",APCDC," ",$S($P(^APCDTKW(APCDCRIT,0),U,12)]"":$P(^APCDTKW(APCDCRIT,0),U,12),1:$P(^APCDTKW(APCDCRIT,0),U,6))," has not been selected.",! Q

 .K APCDCSEL(APCDC)

 .W !,"Item ",$S($P(^APCDTKW(APCDCRIT,0),U,12)]"":$P(^APCDTKW(APCDCRIT,0),U,12),1:$P(^APCDTKW(APCDCRIT,0),U,6))," removed from selected list of items."

REMX ;

 S DIR(0)="EO",DIR("A")="Hit return to continue..." K DA D ^DIR K DIR

 D BACK

 Q

EXITR ;EP - exit report called from protocol entry

 S APCDQUIT=1

 Q

HELP ; -- help code

 D FULL^VALM1

 W:$D(IOF) @IOF

 W !,"Enter an S to Select an Item, and R to remove a selected item, Q to Quit",!,"the selection process.  To exit the report, enter an E.",!,"Hit a Q to select all ",$S(APCDPTVS="V":"visits",1:"patients"),", bypassing all screens.",!

 S X="?" D DISP^XQORM1 W !

 S DIR(0)="EO",DIR("A")="Hit return to continue..." K DA D ^DIR K DIR

 D BACK

 Q

 ;

BACK ;go back to listman

 D TERM^VALM0

 S VALMBCK="R"

 D INIT

 D HDR

 K DIR

 K X,Y,Z,I

 Q

EXIT ; -- exit code

 K APCDDISP

 K VALMCC,VALMHDR

 Q

 ;

EXPND ; -- expand code

 Q

 ;

APCDPE    ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 25-JUN-1996 ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;; ;

EN        ; -- main entry point for APCD VGEN SELECT ITEMS

 +1        KILL DIR

           DO ^XBFMK

 +2        DO EN^XBVK("APCD")

 +3        DO EN^VALM("APCDPE COHORT ENTRY MAIN")

 +4        DO CLEAR^VALM1

 +5        DO EN^XBVK("AUPN")

           DO ^XBFMK

 +6        KILL APCDLIST,APCDSEL,APCDI,APCDC,APCDCRIT,APCDDISP,APCDHIGH,APCDCUT,APCDANS,VALMHDR,VALMCNT

 +7        IF '$DATA(APCDCSEL)

               WRITE !!,"No items selected for entry!"

               QUIT 

 +8        DO ^APCDPE1

 +9        DO EN^XBVK("APCD")

           DO EN^XBVK("AUPN")

           DO ^XBFMK

 +10       KILL ATXICD

 +11       QUIT 

 +12      ;

HDR       ; -- header code

 +1        SET VALMHDR(1)="                        "_$GET(IORVON)_"PCC ITEM SELECTION MENU"_$GET(IORVOFF)

 +2        SET VALMHDR(2)="The following data items can be selected to be entered on a PCC Visit."

 +3        SET VALMHDR(3)="Choose the items you wish to enter on each PCC Visit."

 +4        QUIT 

 +5       ;

 +6       ;

INIT      ; -- init variables and list array

 +1        KILL APCDDISP,APCDSEL,APCDHIGH,APCDLIST

 +2        SET APCDHIGH=0

           SET X=0

           FOR 

               SET X=$ORDER(^APCDTKW("FP",X))

               IF X'=+X

                   QUIT 

               SET Y=$ORDER(^APCDTKW("FP",X,""))

               SET APCDHIGH=APCDHIGH+1

               SET APCDSEL(APCDHIGH)=Y

 +3        SET APCDCUT=((APCDHIGH/3)+1)\1

 +4        SET (C,I)=0

           SET J=1

           SET K=1

           FOR 

               SET I=$ORDER(APCDSEL(I))

               IF I'=+I!($DATA(APCDDISP(I)))

                   QUIT 

               Begin DoDot:1

 +5                SET C=C+1

                   SET APCDLIST(C,0)=I_") "_$SELECT($DATA(APCDCSEL(I)):"*",1:" ")_$SELECT($PIECE(^APCDTKW(APCDSEL(I),0),U,12)]"":$EXTRACT($PIECE(^APCDTKW(APCDSEL(I),0),U,12),1,20),1:$EXTRACT($PIECE(^APCDTKW(APCDSEL(I),0),U,6),1,20))

                   SET APCDDISP(I)=""

                   SET APCDLIST("IDX",C,C)=""

 +6                SET J=I+APCDCUT

 +7                IF $DATA(APCDSEL(J))

                       IF '$DATA(APCDDISP(J))

                           SET $EXTRACT(APCDLIST(C,0),28)=J_") "_$SELECT($DATA(APCDCSEL(J)):"*",1:" ")_$SELECT($PIECE(^APCDTKW(APCDSEL(J),0),U,12)]"":$EXTRACT($PIECE(^APCDTKW(APCDSEL(J),0),U,12),1,20),1:$EXTRACT($PIECE(^APCDTKW(APCDSEL(J),0),U,6),1,20))

                           SET APCDDISP(J)=""

 +8                SET K=J+APCDCUT

 +9                IF $DATA(APCDSEL(K))

                       IF '$DATA(APCDDISP(K))

                           SET $EXTRACT(APCDLIST(C,0),55)=K_") "_$SELECT($DATA(APCDCSEL(K)):"*",1:" ")_$SELECT($PIECE(^APCDTKW(APCDSEL(K),0),U,12)]"":$EXTRACT($PIECE(^APCDTKW(APCDSEL(K),0),U,12),1,20),1:$EXTRACT($PIECE(^APCDTKW(APCDSEL(K),0),U,6),1,20))

                           SET APCDDISP(K)=""

               End DoDot:1

 +10       KILL APCDDISP

 +11       SET VALMCNT=C

 +12       QUIT 

 +13      ;

ADD       ;EP - add an item to the selected list - called from a protocol

 +1        WRITE !

           SET DIR(0)="LO^1:"_APCDHIGH

           SET DIR("A")="Which item(s)"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF Y=""

               WRITE !,"No items selected."

               GOTO ADDX

 +3        IF $DATA(DIRUT)

               WRITE !,"No items selected."

               GOTO ADDX

 +4        FOR APCDI=1:1

               SET APCDC=$PIECE(Y,",",APCDI)

               IF APCDC=""

                   QUIT 

               SET X=APCDSEL(APCDC)

               SET APCDCSEL(APCDC)=X

 +5        DO FULL^VALM1

           IF $DATA(IOF)

               WRITE @IOF

ADDX      ;

 +1        DO BACK

 +2        QUIT 

REM       ;EP - remove a selected item - called from protocol entry

 +1        IF '$DATA(APCDCSEL)

               WRITE !!,"No items have been selected.",!

               HANG 2

               GOTO REMX

 +2        SET DIR(0)="LO^:"

           SET DIR("A")="Remove which selected item"

           KILL DA

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF Y=""

               WRITE !,"No items selected."

               GOTO REMX

 +4        IF $DATA(DIRUT)

               WRITE !,"No items selected."

               GOTO REMX

 +5        SET APCDANS=Y

           SET APCDC=""

           FOR APCDI=1:1

               SET APCDC=$PIECE(APCDANS,",",APCDI)

               IF APCDC=""

                   QUIT 

               SET APCDCRIT=APCDSEL(APCDC)

               Begin DoDot:1

 +6                IF '$DATA(APCDCSEL(APCDC))

                       WRITE !,"Item ",APCDC," ",$SELECT($PIECE(^APCDTKW(APCDCRIT,0),U,12)]"":$PIECE(^APCDTKW(APCDCRIT,0),U,12),1:$PIECE(^APCDTKW(APCDCRIT,0),U,6))," has not been selected.",!

                       QUIT 

 +7                KILL APCDCSEL(APCDC)

 +8                WRITE !,"Item ",$SELECT($PIECE(^APCDTKW(APCDCRIT,0),U,12)]"":$PIECE(^APCDTKW(APCDCRIT,0),U,12),1:$PIECE(^APCDTKW(APCDCRIT,0),U,6))," removed from selected list of items."

               End DoDot:1

REMX      ;

 +1        SET DIR(0)="EO"

           SET DIR("A")="Hit return to continue..."

           KILL DA

           DO ^DIR

           KILL DIR

 +2        DO BACK

 +3        QUIT 

EXITR     ;EP - exit report called from protocol entry

 +1        SET APCDQUIT=1

 +2        QUIT 

HELP      ; -- help code

 +1        DO FULL^VALM1

 +2        IF $DATA(IOF)

               WRITE @IOF

 +3        WRITE !,"Enter an S to Select an Item, and R to remove a selected item, Q to Quit",!,"the selection process.  To exit the report, enter an E.",!,"Hit a Q to select all ",$SELECT(APCDPTVS="V":"visits",1:"patients"),", bypassing all screens.",!

 +4        SET X="?"

           DO DISP^XQORM1

           WRITE !

 +5        SET DIR(0)="EO"

           SET DIR("A")="Hit return to continue..."

           KILL DA

           DO ^DIR

           KILL DIR

 +6        DO BACK

 +7        QUIT 

 +8       ;

BACK      ;go back to listman

 +1        DO TERM^VALM0

 +2        SET VALMBCK="R"

 +3        DO INIT

 +4        DO HDR

 +5        KILL DIR

 +6        KILL X,Y,Z,I

 +7        QUIT 

EXIT      ; -- exit code

 +1        KILL APCDDISP

 +2        KILL VALMCC,VALMHDR

 +3        QUIT 

 +4       ;

EXPND     ; -- expand code

 +1        QUIT 

 +2       ;