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 ;
