ACMGTPZ ; IHS/TUCSON/TMJ - LOOKUP & EDIT REGISTER W/O SCREEN ;
;;2.0;ACM CASE MANAGEMENT SYSTEM;;JAN 10, 1996
;;SAME AS ACMGTP WITHOUT SCREEN FOR REGISTER SELECTION
;LOOKUP AND EDIT REGISTERS
;INTERNAL ENTRY POINT: RGTP
EN D RGTP
EXIT K ACMU1,ACMU11,ACMX,ACMI,ACMJ,ACM,ACMQKI,ACMQK,ACMY,ACMRGCUS,ACMRGMGR,ACMRGUSR
K ACMQUIT,ACMZ
I '$D(ACMRGTP) K ACMRG,ACMRGNA
Q
;
RGTP ;EP;TO SELECT AND CREATE A REGISTER
D HEAD^ACMMENU
RGTPX ;EP;TO SELECT AND CREATE A REGISTER WITHOUT GETTING HEADER
S ACMX="REGISTER SELECTION UTILITY"
W !!,?80-$L(ACMX)\2,ACMX,!
K:$D(ACMRGTP) ACMRGMGR,ACMRGUSR,ACMRGCUS
K:$D(ACMRGMGR) ACMRGTP,ACMRGUSR
K:$D(ACMRGUSR) ACMRGMGR,ACMRGTP,ACMRGCUS
K:$D(ACMRGCUS) ACMRGTP,ACMRGUSR
S ACMRGX(3)="I '$D(^ACM(41.1,ACMRG,""AU"",""B"",DUZ)) S ACMJ=ACMJ-1",ACMRGX(4)="X ACMRGX(5)",ACMRGX(5)="W:ACMJ#2=1 !?14 W:ACMJ#2=0 ?45 W ACMRGX"
S ACMRGX=""
F ACMJ=1:1 S ACMRGX=$O(^ACM(41.1,"B",ACMRGX)) Q:ACMRGX="" D RGTPA
K ACMRG,ACMRGX,ACMJ,ACMI
D RGTP1,EXIT
Q
;
RGTPA S ACMRG="",ACMRG=$O(^ACM(41.1,"B",ACMRGX,ACMRG))
;X:$D(ACMRGTP) ACMRGX(3)
X:$D(ACMRGTP) ACMRGX(4)
X:'$D(ACMRGTP) ACMRGX(5)
Q
;
RGTP1 I $D(ACMRGUSR) S ACMRGUSR=DUZ,DIC(0)="AEMQZ"
I $D(ACMRGCUS) S ACMRGCUS=DUZ,DIC(0)="AEMQZ"
I $D(ACMRGTP) S DIC(0)="AEMQZ"
I $D(ACMRGMGR) S ACMRGMGR=DUZ,DIC(0)="AELMQZ"
S (DIC,DIE)="^ACM(41.1,",DIC("A")=" REGISTER: "
I $D(ACMRGTP) S DIC(1)="^ACM(41.1)" ;,DIC("S")="I $D(@DIC(1)@(+Y,""AU"",""B"",DUZ))"
D DIC
I $E(X)=U!(X="")!(Y<1) S (XQUIT,ACMQUIT)="" K ACMRG,ACMRGNA Q
S (DA,ACMRG)=+Y,ACMRGNA=$P(^ACM(41.1,ACMRG,0),U)
Q:$D(ACMTRN)
I $D(ACMDELRG) S ACMRGTP="" Q
I $D(ACMRGTP),'$D(ACMTRN) S (ACMEP,ACMES,ACMEP,ACMPP)="" D ^ACMCTRL Q
RGTP2 I '$D(ACMRGTP)&($D(ACMRGMGR)!$D(ACMRGUSR)) S DR=$S($D(ACMRGMGR):"[ACM REGISTER SETUP]",$D(ACMRGUSR):".05T",1:"") D:$D(ACMRGUSR) USER D DIE Q:'$D(^ACM(41.1,ACMRG,0))
I $D(ACMRGCUS),'$D(ACMQUIT) D SLCT
Q
;
SLCT F D SELECT Q:$D(ACMQUIT)
K ACMQUIT
Q
SELECT D HEAD^ACMMENU
W !!
S ACMX="",ACMU1=0
;F ACMU1=1:1 S ACMX=$O(^ACM(56,"B",ACMX)) Q:ACMX="" S ACMY=$O(^ACM(56,"B",ACMX,"")),ACMZ(ACMU1)=ACMY,ACMX(ACMU1)=ACMX
F S ACMX=$O(^ACM(56,"B",ACMX)) Q:ACMX="" S ACMU1=ACMU1+1,ACMY=$O(^ACM(56,"B",ACMX,"")),ACMZ(ACMU1)=ACMY,ACMX(ACMU1)=ACMX
S ACMU11=ACMU1\2+(ACMU1#2)
F ACM=1:1:ACMU11 D
.S ACMU1=ACM,ACMY=ACMZ(ACMU1)
.W !?10,$J(ACMU1,3)_")",?$X+2,ACMX(ACMU1)
.I $D(^ACM(41.1,ACMRG,2,ACMY)) W ?37,"<=="
.S ACMU1=ACM+ACMU11
.;Q:'$D(ACMZ(ACMU1)) ;S ACMU1=ACMU1-1 Q
.I '$D(ACMZ(ACMU1)) S ACMU1=ACMU1-1 Q
.S ACMY=ACMZ(ACMU1)
.W ?45,$J(ACMU1,3)_")",?$X+2,ACMX(ACMU1)
.I $D(^ACM(41.1,ACMRG,2,ACMY)) W ?68,"<=="
S ACMU1=ACMU1+1
I ACMU1#2 W !?10
W ?45
W $J(ACMU1,3)_")"," All data types"
SLCT1 S DIR(0)="SOA^A:ADD;D:DELETE",DIR("A")="'A' to ADD, 'D' to DELETE option(s) ==> ",DIR("?")="Type 'A' to ADD, 'D' to DELETE option(s) ==> "
W !!
D ^DIR K DIR
I U[$E(X)!(X="") S ACMQUIT="" Q
S ACMQK=Y
W !!?10,"'<==' indicates option already selected for this register.",!?10,"To select several data types separate them with commas.",!?10,"For example: ==> 1,3,7,9"
K DR
S:$E(ACMQK)="D" DR=".01///@"
S DIR(0)="LOA^1:"_ACMU1,DIR("A")="Select option(s) ==> ",DIR("?")="Type a number from 1 to "_ACMU1
W !
D ^DIR K DIR
I U[$E(X)!(X="") S ACMQUIT="" Q
S ACMQK=Y
S:$E(ACMQK,$L(ACMQK))="," ACMQK=$E(ACMQK,1,$L(ACMQK)-1)
I ACMQK=ACMU1 D ALL Q
LOOP S ACMCNT=$L(ACMQK,","),ACMQK1=ACMQK
W ! D WAIT^DICD W !
F ACMLI=1:1:ACMCNT S ACMQK=$P(ACMQK1,",",ACMLI) D SET
Q
;
SET Q:ACMQK>(ACMU1-1)
;Q:'$D(ACMZ(ACMQK))
S (DA,X,DINUM)=ACMZ(ACMQK),DA(1)=ACMRG
K DIC,DD S (DIE,DIC)="^ACM(41.1,"_ACMRG_",2,",DIC(0)="L"
S:'$D(^ACM(41.1,ACMRG,2,0)) ^ACM(41.1,ACMRG,2,0)="^9002241.13P^^"
I '$D(DR) K DD,DO D FILE^DICN K DIC,DD,DR
D:$D(DR) DIE
Q
;
ALL W ! D WAIT^DICD W !
F ACMQK=1:1:(ACMU1-1) D SET
Q
;
USER D HEAD^ACMMENU
S ACMX="AUTHORIZED USERS"
W !?80-$L(ACMX)\2,ACMX,!!
S ACMX=""
F ACMU1=1:1 S ACMX=$O(^ACM(41.1,ACMRG,"AU","B",ACMX)) Q:ACMX="" D USR1
K ACMU1,ACMX,ACMY
W !
Q
;
USR1 Q:'$D(^VA(200,ACMX,0))
S ACMY=$P(^VA(200,ACMX,0),U)
I $D(ACMY) W:ACMU1#2=1 !?14 W:ACMU1#2=0 ?45 W ACMY
Q
;
DIC W ! D ^DIC K DIC,DR,DD Q
DIE D ^DIE K DIC,DIE,DA Q
ACMGTPZ ; IHS/TUCSON/TMJ - LOOKUP & EDIT REGISTER W/O SCREEN ;
+1 ;;2.0;ACM CASE MANAGEMENT SYSTEM;;JAN 10, 1996
+2 ;;SAME AS ACMGTP WITHOUT SCREEN FOR REGISTER SELECTION
+3 ;LOOKUP AND EDIT REGISTERS
+4 ;INTERNAL ENTRY POINT: RGTP
EN DO RGTP
EXIT KILL ACMU1,ACMU11,ACMX,ACMI,ACMJ,ACM,ACMQKI,ACMQK,ACMY,ACMRGCUS,ACMRGMGR,ACMRGUSR
+1 KILL ACMQUIT,ACMZ
+2 IF '$DATA(ACMRGTP)
KILL ACMRG,ACMRGNA
+3 QUIT
+4 ;
RGTP ;EP;TO SELECT AND CREATE A REGISTER
+1 DO HEAD^ACMMENU
RGTPX ;EP;TO SELECT AND CREATE A REGISTER WITHOUT GETTING HEADER
+1 SET ACMX="REGISTER SELECTION UTILITY"
+2 WRITE !!,?80-$LENGTH(ACMX)\2,ACMX,!
+3 IF $DATA(ACMRGTP)
KILL ACMRGMGR,ACMRGUSR,ACMRGCUS
+4 IF $DATA(ACMRGMGR)
KILL ACMRGTP,ACMRGUSR
+5 IF $DATA(ACMRGUSR)
KILL ACMRGMGR,ACMRGTP,ACMRGCUS
+6 IF $DATA(ACMRGCUS)
KILL ACMRGTP,ACMRGUSR
+7 SET ACMRGX(3)="I '$D(^ACM(41.1,ACMRG,""AU"",""B"",DUZ)) S ACMJ=ACMJ-1"
SET ACMRGX(4)="X ACMRGX(5)"
SET ACMRGX(5)="W:ACMJ#2=1 !?14 W:ACMJ#2=0 ?45 W ACMRGX"
+8 SET ACMRGX=""
+9 FOR ACMJ=1:1
SET ACMRGX=$ORDER(^ACM(41.1,"B",ACMRGX))
IF ACMRGX=""
QUIT
DO RGTPA
+10 KILL ACMRG,ACMRGX,ACMJ,ACMI
+11 DO RGTP1
DO EXIT
+12 QUIT
+13 ;
RGTPA SET ACMRG=""
SET ACMRG=$ORDER(^ACM(41.1,"B",ACMRGX,ACMRG))
+1 ;X:$D(ACMRGTP) ACMRGX(3)
+2 IF $DATA(ACMRGTP)
XECUTE ACMRGX(4)
+3 IF '$DATA(ACMRGTP)
XECUTE ACMRGX(5)
+4 QUIT
+5 ;
RGTP1 IF $DATA(ACMRGUSR)
SET ACMRGUSR=DUZ
SET DIC(0)="AEMQZ"
+1 IF $DATA(ACMRGCUS)
SET ACMRGCUS=DUZ
SET DIC(0)="AEMQZ"
+2 IF $DATA(ACMRGTP)
SET DIC(0)="AEMQZ"
+3 IF $DATA(ACMRGMGR)
SET ACMRGMGR=DUZ
SET DIC(0)="AELMQZ"
+4 SET (DIC,DIE)="^ACM(41.1,"
SET DIC("A")=" REGISTER: "
+5 ;,DIC("S")="I $D(@DIC(1)@(+Y,""AU"",""B"",DUZ))"
IF $DATA(ACMRGTP)
SET DIC(1)="^ACM(41.1)"
+6 DO DIC
+7 IF $EXTRACT(X)=U!(X="")!(Y<1)
SET (XQUIT,ACMQUIT)=""
KILL ACMRG,ACMRGNA
QUIT
+8 SET (DA,ACMRG)=+Y
SET ACMRGNA=$PIECE(^ACM(41.1,ACMRG,0),U)
+9 IF $DATA(ACMTRN)
QUIT
+10 IF $DATA(ACMDELRG)
SET ACMRGTP=""
QUIT
+11 IF $DATA(ACMRGTP)
IF '$DATA(ACMTRN)
SET (ACMEP,ACMES,ACMEP,ACMPP)=""
DO ^ACMCTRL
QUIT
RGTP2 IF '$DATA(ACMRGTP)&($DATA(ACMRGMGR)!$DATA(ACMRGUSR))
SET DR=$SELECT($DATA(ACMRGMGR):"[ACM REGISTER SETUP]",$DATA(ACMRGUSR):".05T",1:"")
IF $DATA(ACMRGUSR)
DO USER
DO DIE
IF '$DATA(^ACM(41.1,ACMRG,0))
QUIT
+1 IF $DATA(ACMRGCUS)
IF '$DATA(ACMQUIT)
DO SLCT
+2 QUIT
+3 ;
SLCT FOR
DO SELECT
IF $DATA(ACMQUIT)
QUIT
+1 KILL ACMQUIT
+2 QUIT
SELECT DO HEAD^ACMMENU
+1 WRITE !!
+2 SET ACMX=""
SET ACMU1=0
+3 ;F ACMU1=1:1 S ACMX=$O(^ACM(56,"B",ACMX)) Q:ACMX="" S ACMY=$O(^ACM(56,"B",ACMX,"")),ACMZ(ACMU1)=ACMY,ACMX(ACMU1)=ACMX
+4 FOR
SET ACMX=$ORDER(^ACM(56,"B",ACMX))
IF ACMX=""
QUIT
SET ACMU1=ACMU1+1
SET ACMY=$ORDER(^ACM(56,"B",ACMX,""))
SET ACMZ(ACMU1)=ACMY
SET ACMX(ACMU1)=ACMX
+5 SET ACMU11=ACMU1\2+(ACMU1#2)
+6 FOR ACM=1:1:ACMU11
Begin DoDot:1
+7 SET ACMU1=ACM
SET ACMY=ACMZ(ACMU1)
+8 WRITE !?10,$JUSTIFY(ACMU1,3)_")",?$X+2,ACMX(ACMU1)
+9 IF $DATA(^ACM(41.1,ACMRG,2,ACMY))
WRITE ?37,"<=="
+10 SET ACMU1=ACM+ACMU11
+11 ;Q:'$D(ACMZ(ACMU1)) ;S ACMU1=ACMU1-1 Q
+12 IF '$DATA(ACMZ(ACMU1))
SET ACMU1=ACMU1-1
QUIT
+13 SET ACMY=ACMZ(ACMU1)
+14 WRITE ?45,$JUSTIFY(ACMU1,3)_")",?$X+2,ACMX(ACMU1)
+15 IF $DATA(^ACM(41.1,ACMRG,2,ACMY))
WRITE ?68,"<=="
End DoDot:1
+16 SET ACMU1=ACMU1+1
+17 IF ACMU1#2
WRITE !?10
+18 WRITE ?45
+19 WRITE $JUSTIFY(ACMU1,3)_")"," All data types"
SLCT1 SET DIR(0)="SOA^A:ADD;D:DELETE"
SET DIR("A")="'A' to ADD, 'D' to DELETE option(s) ==> "
SET DIR("?")="Type 'A' to ADD, 'D' to DELETE option(s) ==> "
+1 WRITE !!
+2 DO ^DIR
KILL DIR
+3 IF U[$EXTRACT(X)!(X="")
SET ACMQUIT=""
QUIT
+4 SET ACMQK=Y
+5 WRITE !!?10,"'<==' indicates option already selected for this register.",!?10,"To select several data types separate them with commas.",!?10,"For example: ==> 1,3,7,9"
+6 KILL DR
+7 IF $EXTRACT(ACMQK)="D"
SET DR=".01///@"
+8 SET DIR(0)="LOA^1:"_ACMU1
SET DIR("A")="Select option(s) ==> "
SET DIR("?")="Type a number from 1 to "_ACMU1
+9 WRITE !
+10 DO ^DIR
KILL DIR
+11 IF U[$EXTRACT(X)!(X="")
SET ACMQUIT=""
QUIT
+12 SET ACMQK=Y
+13 IF $EXTRACT(ACMQK,$LENGTH(ACMQK))=","
SET ACMQK=$EXTRACT(ACMQK,1,$LENGTH(ACMQK)-1)
+14 IF ACMQK=ACMU1
DO ALL
QUIT
LOOP SET ACMCNT=$LENGTH(ACMQK,",")
SET ACMQK1=ACMQK
+1 WRITE !
DO WAIT^DICD
WRITE !
+2 FOR ACMLI=1:1:ACMCNT
SET ACMQK=$PIECE(ACMQK1,",",ACMLI)
DO SET
+3 QUIT
+4 ;
SET IF ACMQK>(ACMU1-1)
QUIT
+1 ;Q:'$D(ACMZ(ACMQK))
+2 SET (DA,X,DINUM)=ACMZ(ACMQK)
SET DA(1)=ACMRG
+3 KILL DIC,DD
SET (DIE,DIC)="^ACM(41.1,"_ACMRG_",2,"
SET DIC(0)="L"
+4 IF '$DATA(^ACM(41.1,ACMRG,2,0))
SET ^ACM(41.1,ACMRG,2,0)="^9002241.13P^^"
+5 IF '$DATA(DR)
KILL DD,DO
DO FILE^DICN
KILL DIC,DD,DR
+6 IF $DATA(DR)
DO DIE
+7 QUIT
+8 ;
ALL WRITE !
DO WAIT^DICD
WRITE !
+1 FOR ACMQK=1:1:(ACMU1-1)
DO SET
+2 QUIT
+3 ;
USER DO HEAD^ACMMENU
+1 SET ACMX="AUTHORIZED USERS"
+2 WRITE !?80-$LENGTH(ACMX)\2,ACMX,!!
+3 SET ACMX=""
+4 FOR ACMU1=1:1
SET ACMX=$ORDER(^ACM(41.1,ACMRG,"AU","B",ACMX))
IF ACMX=""
QUIT
DO USR1
+5 KILL ACMU1,ACMX,ACMY
+6 WRITE !
+7 QUIT
+8 ;
USR1 IF '$DATA(^VA(200,ACMX,0))
QUIT
+1 SET ACMY=$PIECE(^VA(200,ACMX,0),U)
+2 IF $DATA(ACMY)
IF ACMU1#2=1
WRITE !?14
IF ACMU1#2=0
WRITE ?45
WRITE ACMY
+3 QUIT
+4 ;
DIC WRITE !
DO ^DIC
KILL DIC,DR,DD
QUIT
DIE DO ^DIE
KILL DIC,DIE,DA
QUIT
