ACDRL4 ;IHS/ADC/EDE/KML - GENERAL RETRIEVAL;
;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
;; ;
EN ; -- main entry point for ACD GENRET SELECTION ITEMS
K ACDCSEL
D EN^VALM("ACD GENERAL RETRIEVAL TEMPLATE")
D CLEAR^VALM1
K ACDDISP,ACDSEL,ACDLIST,C,X,I,K,J,ACDHIGH,ACDCUT,ACDCSEL,ACDCNTL
K VALMHDR,VALMCNT
Q
;
;
HDR ; -- header code
D @("HDR"_ACDCNTL)
Q
HDRS ;
S VALMHDR(1)=" "_$G(IORVON)_$S(ACDPTVS="V":"CDMIS RECORD ",1:"PATIENT ")_"Selection Menu"_$G(IORVOFF)
S VALMHDR(2)=$S(ACDPTVS="V":"CDMIS Records",1:"Patients")_" can be selected based upon any of the following items. Select"
S VALMHDR(3)="as many as you wish, in any order or combination. An (*) asterisk indicates"
S VALMHDR(4)="items already selected. To bypass screens and select all "_$S(ACDPTVS="V":"visits",1:"patients")_" hit Q."
Q
;
HDRP ;print selection header
S VALMHDR(1)=" "_$G(IORVON)_"PRINT ITEM SELECTION MENU"_$G(IORVOFF)
S VALMHDR(2)="The following data items can be printed. Choose the items in the order you"
S VALMHDR(3)="want them to appear on the printout. Keep in mind that you have an 80"
S VALMHDR(4)="column screen available, or a printer with either 80 or 132 column width."
Q
;
HDRR ;sort header
S VALMHDR(1)=""
S VALMHDR(2)=" "_$G(IORVON)_"SORT ITEM SELECTION MENU"_$G(IORVOFF)
S VALMHDR(3)="The "_$S(ACDPTVS="P":"patients",1:"visits")_" displayed can be SORTED by ONLY ONE of the following items."
S VALMHDR(4)="If you don't select a sort item, the report will be sorted by "_$S(ACDPTVS="V":"record date.",1:"patient name.")
Q
;
INIT ; -- init variables and list array
K ACDDISP,ACDSEL,ACDHIGH,ACDLIST
S ACDHIGH=0,X=0 F S X=$O(^ACDTITEM("C",X)) Q:X'=+X S Y=$O(^ACDTITEM("C",X,"")) I $P(^ACDTITEM(Y,0),U,5)[ACDCNTL,$P(^(0),U,11)[ACDPTVS S ACDHIGH=ACDHIGH+1,ACDSEL(ACDHIGH)=Y
S ACDIONL=$L($G(IORVON)),ACDIOFL=$L($G(IORVOFF))
S ACDCUT=((ACDHIGH/3)+1)\1
S (C,I)=0,J=1,K=1
S E=0
F S I=$O(ACDSEL(I)) Q:I'=+I!($D(ACDDISP(I))) D
. S C=C+1,O=0,F=0,X=" "
. S:$D(ACDCSEL(I)) F=1
. S:F X=$G(IORVON)_"*"
. S X=X_$S($P(^ACDTITEM(ACDSEL(I),0),U,12)="":$E($P(^(0),U),1,20),1:$P(^(0),U,12))
. S:F X=X_$G(IORVOFF)
. S ACDLIST(C,0)=$S(E:$G(IORVOFF),1:"")_I_") "_X
. S:E O=O+ACDIOFL,E=0
. S ACDDISP(I)="",ACDLIST("IDX",C,C)=""
. S:F O=O+ACDIONL+ACDIOFL
. ;----------
. S J=I+ACDCUT
. I $D(ACDSEL(J)),'$D(ACDDISP(J)) D
.. S F=0,X=" "
.. S:$D(ACDCSEL(J)) F=1
.. S:F X=$G(IORVON)_"*"
.. S X=X_$S($P(^ACDTITEM(ACDSEL(J),0),U,12)="":$E($P(^ACDTITEM(ACDSEL(J),0),U),1,20),1:$P(^(0),U,12))
.. S:F X=X_$G(IORVOFF)
.. S $E(ACDLIST(C,0),28+O)=J_") "_X
.. S ACDDISP(J)=""
.. S:F O=O+ACDIONL+ACDIOFL
.. Q
. ;----------
. S K=J+ACDCUT
. I $D(ACDSEL(K)),'$D(ACDDISP(K)) D
.. S F=0,X=" "
.. S:$D(ACDCSEL(K)) F=1
.. S:F X=$G(IORVON)_"*"
.. S X=X_$S($P(^ACDTITEM(ACDSEL(K),0),U,12)="":$E($P(^ACDTITEM(ACDSEL(K),0),U),1,20),1:$P(^(0),U,12))
.. S:F X=X_$G(IORVOFF)
.. S $E(ACDLIST(C,0),55+O)=K_") "_X
.. S ACDDISP(K)=""
.. S:F E=1
.. Q
. Q
K ACDDISP
S VALMCNT=C
Q
;
;----------
;S (C,I)=0,J=1,K=1 F S I=$O(ACDSEL(I)) Q:I'=+I!($D(ACDDISP(I))) D
;.S C=C+1,ACDLIST(C,0)=I_") "_$S($D(ACDCSEL(I)):"*",1:" ")_$S($P(^ACDTITEM(ACDSEL(I),0),U,12)="":$E($P(^(0),U),1,20),1:$P(^(0),U,12)) S ACDDISP(I)="",ACDLIST("IDX",C,C)=""
;.S J=I+ACDCUT I $D(ACDSEL(J)),'$D(ACDDISP(J)) S $E(ACDLIST(C,0),28)=J_") "_$S($D(ACDCSEL(J)):"*",1:" ")_$S($P(^ACDTITEM(ACDSEL(J),0),U,12)="":$E($P(^ACDTITEM(ACDSEL(J),0),U),1,20),1:$P(^(0),U,12)) S ACDDISP(J)=""
;.S K=J+ACDCUT I $D(ACDSEL(K)),'$D(ACDDISP(K)) S $E(ACDLIST(C,0),55)=K_") "_$S($D(ACDCSEL(K)):"*",1:" ")_$S($P(^ACDTITEM(ACDSEL(K),0),U,12)="":$E($P(^ACDTITEM(ACDSEL(K),0),U),1,20),1:$P(^(0),U,12)) S ACDDISP(K)=""
;----------
;
ADD ;EP - add an item to the selected list - called from a protocol
G:ACDCNTL="R" SELECTR
W ! S DIR(0)="LO^1:"_ACDHIGH,DIR("A")="Which "_$S(ACDPTVS="P":"patient",1:"record")_" 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
D FULL^VALM1 W:$D(IOF) @IOF
D @("SELECT"_ACDCNTL)
ADDX ;
S DIR(0)="EO",DIR("A")="Hit return to continue..." K DA D ^DIR K DIR
D BACK
Q
SELECTS ;select screen items
S ACDANS=Y,ACDC="" F ACDI=1:1 S ACDC=$P(ACDANS,",",ACDI) Q:ACDC="" S ACDCRIT=ACDSEL(ACDC) D
.S ACDTEXT=$P(^ACDTITEM(ACDCRIT,0),U)
.S ACDVAR=$P(^ACDTITEM(ACDCRIT,0),U,6) K ^ACDRPTD(ACDRPT,11,ACDCRIT),^ACDRPTD(ACDRPT,11,"B",ACDCRIT)
.W !!,ACDC,") ",ACDTEXT," Selection."
.I $P(^ACDTITEM(ACDCRIT,0),U,2)]"" S ACDCNT=0,^ACDRPTD(ACDRPT,11,0)="^9002171.81101PA^0^0" D @($P(^ACDTITEM(ACDCRIT,0),U,2)_"^ACDRL0")
.I $D(^ACDRPTD(ACDRPT,11,ACDCRIT,11,1)) S ACDCSEL(ACDC)=""
.Q
D SHOW^ACDRLS
Q
SELECTR ;sort select
W ! S DIR(0)="NO^1:"_ACDHIGH_":0",DIR("A")=$S(ACDCTYP="S":"Sub-total ",1:"Sort ")_$S(ACDPTVS="P":"Patients",1:"visits")_" by which of the above" D ^DIR K DIR
SELECTR1 ;
I Y="",ACDCTYP="D" W !!,"No sort criteria selected ... will sort by "_$S(ACDPTVS="P":"Patient Name",1:"Referral Date")_"." S:ACDPTVS="V" ACDSORT=19,ACDSORV="Referral Date" S:ACDPTVS="P" ACDSORT=119,ACDSORV="Patient Name" H 4 D Q
.S DA=ACDRPT,DIE="^ACDRPTD(",DR=".07////"_ACDSORT D ^DIE K DA,DR,DIE,DIU,DIV,DIY,DIW
I Y="",ACDCTYP'="D" W !!,"No sub-totalling will be done.",!! D Q
.S ACDCTYP="T"
.H 3
.S:ACDPTVS="V" ACDSORT=19,ACDSORV="Referral Date"
.S:ACDPTVS="P" ACDSORT=119,ACDSORV="Patient Name"
S ACDSORT=ACDSEL(+Y),ACDSORV=$P(^ACDTITEM(ACDSORT,0),U),DA=ACDRPT,DIE="^ACDRPTD(",DR=".07////"_ACDSORT D ^DIE K DA,DR,DIE,DIU,DIV,DIY,DIW
Q
SELECTP ;print select - get columns
S ACDANS=Y,ACDC="" F ACDI=1:1 S ACDC=$P(ACDANS,",",ACDI) Q:ACDC="" S ACDCRIT=ACDSEL(ACDC),ACDPCNT=ACDPCNT+1 D
.S DIR(0)="N^2:80:0",DIR("A")="Enter Column width for "_$P(^ACDTITEM(ACDCRIT,0),U)_" (suggested: "_$P(^ACDTITEM(ACDCRIT,0),U,7)_")",DIR("B")=$P(^(0),U,7) D ^DIR K DIR S:$D(DUOUT) DIRUT=1
.I $D(DIRUT) S Y=$P(^ACDTITEM(ACDCRIT,0),U,7)
.S ^ACDRPTD(ACDRPT,12,0)="^9002171.81102PA^1^1"
.I $D(^ACDRPTD(ACDRPT,12,"B",ACDCRIT)) S X=$O(^ACDRPTD(ACDRPT,12,"B",ACDCRIT,"")),ACDTCW=ACDTCW-$P(^ACDRPTD(ACDRPT,12,X,0),U,2)-2,^ACDRPTD(ACDRPT,12,X,0)=ACDCRIT_U_Y D Q
..Q
.S ^ACDRPTD(ACDRPT,12,ACDPCNT,0)=ACDCRIT_U_Y,^ACDRPTD(ACDRPT,12,"B",ACDCRIT,ACDPCNT)="",ACDTCW=ACDTCW+Y+2,ACDCSEL(ACDC)=""
.W !!?15,"Total Report width (including column margins - 2 spaces): ",ACDTCW
.Q
Q
REM ;EP - remove a selected item - called from protocol entry
I '$D(ACDCSEL) 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 ACDANS=Y,ACDC="" F ACDI=1:1 S ACDC=$P(ACDANS,",",ACDI) Q:ACDC="" S ACDCRIT=ACDSEL(ACDC) D
.I '$D(ACDCSEL(ACDC)) W !,"Item ",ACDC," ",$P(^ACDTITEM(ACDCRIT,0),U)," has not been selected.",! Q
.K ACDCSEL(ACDC)
.I ACDCNTL="S" K ^ACDRPTD(ACDRPT,11,ACDCRIT),^ACDRPTD(ACDRPT,11,"B",ACDCRIT)
.I ACDCNTL="P" S X=$O(^ACDVPRT(ACDRPT,12,"B",ACDCRIT,0)) I X K ^ACDRPTD(ACDRPT,12,X),^ACDRPTD(ACDRPT,12,"B",ACDCRIT)
.W !,"Item ",$P(^ACDTITEM(ACDCRIT,0),U)," 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
Q ;EP - quit selections
I ACDCNTL="R" S Y="" G SELECTR1
Q
EXITR ;EP - exit report called from protocol entry
S ACDQUIT=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(ACDPTVS="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 ACDDISP
K VALMCC,VALMHDR
Q
;
EXPND ; -- expand code
Q
;
ACDRL4 ;IHS/ADC/EDE/KML - GENERAL RETRIEVAL;
+1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
+2 ;; ;
EN ; -- main entry point for ACD GENRET SELECTION ITEMS
+1 KILL ACDCSEL
+2 DO EN^VALM("ACD GENERAL RETRIEVAL TEMPLATE")
+3 DO CLEAR^VALM1
+4 KILL ACDDISP,ACDSEL,ACDLIST,C,X,I,K,J,ACDHIGH,ACDCUT,ACDCSEL,ACDCNTL
+5 KILL VALMHDR,VALMCNT
+6 QUIT
+7 ;
+8 ;
HDR ; -- header code
+1 DO @("HDR"_ACDCNTL)
+2 QUIT
HDRS ;
+1 SET VALMHDR(1)=" "_$GET(IORVON)_$SELECT(ACDPTVS="V":"CDMIS RECORD ",1:"PATIENT ")_"Selection Menu"_$GET(IORVOFF)
+2 SET VALMHDR(2)=$SELECT(ACDPTVS="V":"CDMIS Records",1:"Patients")_" can be selected based upon any of the following items. Select"
+3 SET VALMHDR(3)="as many as you wish, in any order or combination. An (*) asterisk indicates"
+4 SET VALMHDR(4)="items already selected. To bypass screens and select all "_$SELECT(ACDPTVS="V":"visits",1:"patients")_" hit Q."
+5 QUIT
+6 ;
HDRP ;print selection header
+1 SET VALMHDR(1)=" "_$GET(IORVON)_"PRINT ITEM SELECTION MENU"_$GET(IORVOFF)
+2 SET VALMHDR(2)="The following data items can be printed. Choose the items in the order you"
+3 SET VALMHDR(3)="want them to appear on the printout. Keep in mind that you have an 80"
+4 SET VALMHDR(4)="column screen available, or a printer with either 80 or 132 column width."
+5 QUIT
+6 ;
HDRR ;sort header
+1 SET VALMHDR(1)=""
+2 SET VALMHDR(2)=" "_$GET(IORVON)_"SORT ITEM SELECTION MENU"_$GET(IORVOFF)
+3 SET VALMHDR(3)="The "_$SELECT(ACDPTVS="P":"patients",1:"visits")_" displayed can be SORTED by ONLY ONE of the following items."
+4 SET VALMHDR(4)="If you don't select a sort item, the report will be sorted by "_$SELECT(ACDPTVS="V":"record date.",1:"patient name.")
+5 QUIT
+6 ;
INIT ; -- init variables and list array
+1 KILL ACDDISP,ACDSEL,ACDHIGH,ACDLIST
+2 SET ACDHIGH=0
SET X=0
FOR
SET X=$ORDER(^ACDTITEM("C",X))
IF X'=+X
QUIT
SET Y=$ORDER(^ACDTITEM("C",X,""))
IF $PIECE(^ACDTITEM(Y,0),U,5)[ACDCNTL
IF $PIECE(^(0),U,11)[ACDPTVS
SET ACDHIGH=ACDHIGH+1
SET ACDSEL(ACDHIGH)=Y
+3 SET ACDIONL=$LENGTH($GET(IORVON))
SET ACDIOFL=$LENGTH($GET(IORVOFF))
+4 SET ACDCUT=((ACDHIGH/3)+1)\1
+5 SET (C,I)=0
SET J=1
SET K=1
+6 SET E=0
+7 FOR
SET I=$ORDER(ACDSEL(I))
IF I'=+I!($DATA(ACDDISP(I)))
QUIT
Begin DoDot:1
+8 SET C=C+1
SET O=0
SET F=0
SET X=" "
+9 IF $DATA(ACDCSEL(I))
SET F=1
+10 IF F
SET X=$GET(IORVON)_"*"
+11 SET X=X_$SELECT($PIECE(^ACDTITEM(ACDSEL(I),0),U,12)="":$EXTRACT($PIECE(^(0),U),1,20),1:$PIECE(^(0),U,12))
+12 IF F
SET X=X_$GET(IORVOFF)
+13 SET ACDLIST(C,0)=$SELECT(E:$GET(IORVOFF),1:"")_I_") "_X
+14 IF E
SET O=O+ACDIOFL
SET E=0
+15 SET ACDDISP(I)=""
SET ACDLIST("IDX",C,C)=""
+16 IF F
SET O=O+ACDIONL+ACDIOFL
+17 ;----------
+18 SET J=I+ACDCUT
+19 IF $DATA(ACDSEL(J))
IF '$DATA(ACDDISP(J))
Begin DoDot:2
+20 SET F=0
SET X=" "
+21 IF $DATA(ACDCSEL(J))
SET F=1
+22 IF F
SET X=$GET(IORVON)_"*"
+23 SET X=X_$SELECT($PIECE(^ACDTITEM(ACDSEL(J),0),U,12)="":$EXTRACT($PIECE(^ACDTITEM(ACDSEL(J),0),U),1,20),1:$PIECE(^(0),U,12))
+24 IF F
SET X=X_$GET(IORVOFF)
+25 SET $EXTRACT(ACDLIST(C,0),28+O)=J_") "_X
+26 SET ACDDISP(J)=""
+27 IF F
SET O=O+ACDIONL+ACDIOFL
+28 QUIT
End DoDot:2
+29 ;----------
+30 SET K=J+ACDCUT
+31 IF $DATA(ACDSEL(K))
IF '$DATA(ACDDISP(K))
Begin DoDot:2
+32 SET F=0
SET X=" "
+33 IF $DATA(ACDCSEL(K))
SET F=1
+34 IF F
SET X=$GET(IORVON)_"*"
+35 SET X=X_$SELECT($PIECE(^ACDTITEM(ACDSEL(K),0),U,12)="":$EXTRACT($PIECE(^ACDTITEM(ACDSEL(K),0),U),1,20),1:$PIECE(^(0),U,12))
+36 IF F
SET X=X_$GET(IORVOFF)
+37 SET $EXTRACT(ACDLIST(C,0),55+O)=K_") "_X
+38 SET ACDDISP(K)=""
+39 IF F
SET E=1
+40 QUIT
End DoDot:2
+41 QUIT
End DoDot:1
+42 KILL ACDDISP
+43 SET VALMCNT=C
+44 QUIT
+45 ;
+46 ;----------
+47 ;S (C,I)=0,J=1,K=1 F S I=$O(ACDSEL(I)) Q:I'=+I!($D(ACDDISP(I))) D
+48 ;.S C=C+1,ACDLIST(C,0)=I_") "_$S($D(ACDCSEL(I)):"*",1:" ")_$S($P(^ACDTITEM(ACDSEL(I),0),U,12)="":$E($P(^(0),U),1,20),1:$P(^(0),U,12)) S ACDDISP(I)="",ACDLIST("IDX",C,C)=""
+49 ;.S J=I+ACDCUT I $D(ACDSEL(J)),'$D(ACDDISP(J)) S $E(ACDLIST(C,0),28)=J_") "_$S($D(ACDCSEL(J)):"*",1:" ")_$S($P(^ACDTITEM(ACDSEL(J),0),U,12)="":$E($P(^ACDTITEM(ACDSEL(J),0),U),1,20),1:$P(^(0),U,12)) S ACDDISP(J)=""
+50 ;.S K=J+ACDCUT I $D(ACDSEL(K)),'$D(ACDDISP(K)) S $E(ACDLIST(C,0),55)=K_") "_$S($D(ACDCSEL(K)):"*",1:" ")_$S($P(^ACDTITEM(ACDSEL(K),0),U,12)="":$E($P(^ACDTITEM(ACDSEL(K),0),U),1,20),1:$P(^(0),U,12)) S ACDDISP(K)=""
+51 ;----------
+52 ;
ADD ;EP - add an item to the selected list - called from a protocol
+1 IF ACDCNTL="R"
GOTO SELECTR
+2 WRITE !
SET DIR(0)="LO^1:"_ACDHIGH
SET DIR("A")="Which "_$SELECT(ACDPTVS="P":"patient",1:"record")_" item(s)"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF Y=""
WRITE !,"No items selected."
GOTO ADDX
+4 IF $DATA(DIRUT)
WRITE !,"No items selected."
GOTO ADDX
+5 DO FULL^VALM1
IF $DATA(IOF)
WRITE @IOF
+6 DO @("SELECT"_ACDCNTL)
ADDX ;
+1 SET DIR(0)="EO"
SET DIR("A")="Hit return to continue..."
KILL DA
DO ^DIR
KILL DIR
+2 DO BACK
+3 QUIT
SELECTS ;select screen items
+1 SET ACDANS=Y
SET ACDC=""
FOR ACDI=1:1
SET ACDC=$PIECE(ACDANS,",",ACDI)
IF ACDC=""
QUIT
SET ACDCRIT=ACDSEL(ACDC)
Begin DoDot:1
+2 SET ACDTEXT=$PIECE(^ACDTITEM(ACDCRIT,0),U)
+3 SET ACDVAR=$PIECE(^ACDTITEM(ACDCRIT,0),U,6)
KILL ^ACDRPTD(ACDRPT,11,ACDCRIT),^ACDRPTD(ACDRPT,11,"B",ACDCRIT)
+4 WRITE !!,ACDC,") ",ACDTEXT," Selection."
+5 IF $PIECE(^ACDTITEM(ACDCRIT,0),U,2)]""
SET ACDCNT=0
SET ^ACDRPTD(ACDRPT,11,0)="^9002171.81101PA^0^0"
DO @($PIECE(^ACDTITEM(ACDCRIT,0),U,2)_"^ACDRL0")
+6 IF $DATA(^ACDRPTD(ACDRPT,11,ACDCRIT,11,1))
SET ACDCSEL(ACDC)=""
+7 QUIT
End DoDot:1
+8 DO SHOW^ACDRLS
+9 QUIT
SELECTR ;sort select
+1 WRITE !
SET DIR(0)="NO^1:"_ACDHIGH_":0"
SET DIR("A")=$SELECT(ACDCTYP="S":"Sub-total ",1:"Sort ")_$SELECT(ACDPTVS="P":"Patients",1:"visits")_" by which of the above"
DO ^DIR
KILL DIR
SELECTR1 ;
+1 IF Y=""
IF ACDCTYP="D"
WRITE !!,"No sort criteria selected ... will sort by "_$SELECT(ACDPTVS="P":"Patient Name",1:"Referral Date")_"."
IF ACDPTVS="V"
SET ACDSORT=19
SET ACDSORV="Referral Date"
IF ACDPTVS="P"
SET ACDSORT=119
SET ACDSORV="Patient Name"
HANG 4
Begin DoDot:1
+2 SET DA=ACDRPT
SET DIE="^ACDRPTD("
SET DR=".07////"_ACDSORT
DO ^DIE
KILL DA,DR,DIE,DIU,DIV,DIY,DIW
End DoDot:1
QUIT
+3 IF Y=""
IF ACDCTYP'="D"
WRITE !!,"No sub-totalling will be done.",!!
Begin DoDot:1
+4 SET ACDCTYP="T"
+5 HANG 3
+6 IF ACDPTVS="V"
SET ACDSORT=19
SET ACDSORV="Referral Date"
+7 IF ACDPTVS="P"
SET ACDSORT=119
SET ACDSORV="Patient Name"
End DoDot:1
QUIT
+8 SET ACDSORT=ACDSEL(+Y)
SET ACDSORV=$PIECE(^ACDTITEM(ACDSORT,0),U)
SET DA=ACDRPT
SET DIE="^ACDRPTD("
SET DR=".07////"_ACDSORT
DO ^DIE
KILL DA,DR,DIE,DIU,DIV,DIY,DIW
+9 QUIT
SELECTP ;print select - get columns
+1 SET ACDANS=Y
SET ACDC=""
FOR ACDI=1:1
SET ACDC=$PIECE(ACDANS,",",ACDI)
IF ACDC=""
QUIT
SET ACDCRIT=ACDSEL(ACDC)
SET ACDPCNT=ACDPCNT+1
Begin DoDot:1
+2 SET DIR(0)="N^2:80:0"
SET DIR("A")="Enter Column width for "_$PIECE(^ACDTITEM(ACDCRIT,0),U)_" (suggested: "_$PIECE(^ACDTITEM(ACDCRIT,0),U,7)_")"
SET DIR("B")=$PIECE(^(0),U,7)
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
SET Y=$PIECE(^ACDTITEM(ACDCRIT,0),U,7)
+4 SET ^ACDRPTD(ACDRPT,12,0)="^9002171.81102PA^1^1"
+5 IF $DATA(^ACDRPTD(ACDRPT,12,"B",ACDCRIT))
SET X=$ORDER(^ACDRPTD(ACDRPT,12,"B",ACDCRIT,""))
SET ACDTCW=ACDTCW-$PIECE(^ACDRPTD(ACDRPT,12,X,0),U,2)-2
SET ^ACDRPTD(ACDRPT,12,X,0)=ACDCRIT_U_Y
Begin DoDot:2
+6 QUIT
End DoDot:2
QUIT
+7 SET ^ACDRPTD(ACDRPT,12,ACDPCNT,0)=ACDCRIT_U_Y
SET ^ACDRPTD(ACDRPT,12,"B",ACDCRIT,ACDPCNT)=""
SET ACDTCW=ACDTCW+Y+2
SET ACDCSEL(ACDC)=""
+8 WRITE !!?15,"Total Report width (including column margins - 2 spaces): ",ACDTCW
+9 QUIT
End DoDot:1
+10 QUIT
REM ;EP - remove a selected item - called from protocol entry
+1 IF '$DATA(ACDCSEL)
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 ACDANS=Y
SET ACDC=""
FOR ACDI=1:1
SET ACDC=$PIECE(ACDANS,",",ACDI)
IF ACDC=""
QUIT
SET ACDCRIT=ACDSEL(ACDC)
Begin DoDot:1
+6 IF '$DATA(ACDCSEL(ACDC))
WRITE !,"Item ",ACDC," ",$PIECE(^ACDTITEM(ACDCRIT,0),U)," has not been selected.",!
QUIT
+7 KILL ACDCSEL(ACDC)
+8 IF ACDCNTL="S"
KILL ^ACDRPTD(ACDRPT,11,ACDCRIT),^ACDRPTD(ACDRPT,11,"B",ACDCRIT)
+9 IF ACDCNTL="P"
SET X=$ORDER(^ACDVPRT(ACDRPT,12,"B",ACDCRIT,0))
IF X
KILL ^ACDRPTD(ACDRPT,12,X),^ACDRPTD(ACDRPT,12,"B",ACDCRIT)
+10 WRITE !,"Item ",$PIECE(^ACDTITEM(ACDCRIT,0),U)," 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
Q ;EP - quit selections
+1 IF ACDCNTL="R"
SET Y=""
GOTO SELECTR1
+2 QUIT
EXITR ;EP - exit report called from protocol entry
+1 SET ACDQUIT=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(ACDPTVS="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 ACDDISP
+2 KILL VALMCC,VALMHDR
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
