ACRFDRCL ;IHS/OIRM/DSD/THL,AEF - REQUEST TYPE SEQUENCE CONTROL; [ 11/01/2001 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
;;ROUTINE USED TO ESTABLISH AND CHANGE REQUEST TYPE APPROVAL
;;SEQUENCE CONTROL
EN S DIC(0)="AEMQZ"
D AREA^ACRFAS
Q:$D(ACRQUIT)!'$G(ACRADA)
D:'$D(^ACRDOCA("AC",ACRADA)) NEWSU
F D EN1 Q:$D(ACRQUIT)!$D(ACROUT)
EXIT K ACRDATA,ACRDATA1,ACRQUIT,ACRSET,ACRJ,ACRMAX,ACRREFC,ACRTT,ACRCAT,ACRI,ACRJJ,ACRORDR,ACRTX,ACRTXNAM,ACRJJJ
Q
EN1 D SELECT,LOCATION:'$D(ACRQUIT)
Q
SELECT S ACRXDRCL="ESTABLISH APPROVAL SEQUENCE FOR: "_$P(^AUTTAREA(+^ACRSYS(ACRADA,0),0),U)
S ACRSET=""
D DISPLAY^ACRFTXTP
K ACRXDRCL
S DIR(0)="NOA^1:"_ACRJ_"^K:X'?1N.2N!(X<1)!(X>ACRJ) X"
S DIR("A")="Which one ==> "
W !
D DIR^ACRFDIC
Q:$D(ACRQUIT)!$D(ACROUT)
S (ACRRCDA,DA)=+ACRTX(X)
S ACRCAT=$P(ACRTX(X),U,6)
S ACRREFC=$P(^ACRTXTYP(DA,0),U)
Q
LOCATION F D DISPLAY,SET Q:$D(ACRQUIT)!$D(ACROUT)
K ACRQUIT
Q
DISPLAY W @IOF
W !!?9,"APPROVAL SEQUENCE FOR: ",@ACRON,ACRREFC,@ACROF
W !!,"NO. SEQ"
W ?9,"APPROVAL CATEGORY"
W ?40,"NO. SEQ"
W ?49,"APPROVAL CATEGORY"
W !,"--- --- -------------------------"
W ?40,"--- --- -------------------------"
N ACRY
S ACRY=0
K ACRDATA
F ACRJ=1:1 S ACRY=$O(^ACRAPVT("C",ACRCAT,ACRY)) Q:'ACRY D
.S ACRORDR=$P(^ACRAPVT(ACRY,0),U,4)
.S ACRDATA(100+ACRORDR)=ACRRCDA_U_ACRY_U
.S (ACRMAX,ACRSET)=ACRJ
S ACRDATA(100+ACRJ)=ACRRCDA_U_(19)_U
S ACRDATA(100+ACRJ+1)=ACRRCDA_U_15_U
S ACRSET=ACRJ+1
D DD1
S ACRJ=0
S ACRMAX=ACRMAX+(ACRMAX#2)
F S ACRJ=$O(ACRDATA(ACRJ)) Q:ACRJ>12!('ACRJ) D DISP1
K ACRX,ACRSEQ,ACRAPDA
Q
DD1 S ACRJ=100
S ACRMAX=0
F S ACRJ=$O(ACRDATA(ACRJ)) Q:'ACRJ D
.S ACRAPDA=$P(ACRDATA(ACRJ),U,2)
.I '$D(ACRDATA1),$D(^ACRDOCA("AC",ACRADA,ACRRCDA,ACRAPDA)) S ACRSEQ=$O(^(ACRAPDA,"")),ACRSEQX=$O(^(ACRSEQ,0)) S:$P(^ACRDOCA(ACRSEQX,0),U,4)]"" ACRDATA(ACRSEQ,$P(^(0),U,4))=""
.E S ACRSEQ=$P($G(ACRDATA1(ACRJ)),U,3)
.I ACRSEQ D
..S ACRDATA(ACRSEQ)=ACRDATA(ACRJ)_ACRSEQ D
..K ACRDATA(ACRJ)
..S ACRMAX=$S(ACRSEQ>ACRMAX:ACRSEQ,1:ACRMAX)
S ACRJ=100
F S ACRJ=$O(ACRDATA(ACRJ)) Q:'ACRJ D
.S ACRMAX=ACRMAX+1
.S ACRDATA(ACRMAX)=ACRDATA(ACRJ)
.K ACRDATA(ACRJ)
Q
DISP1 S ACRAPDA=$P(ACRDATA(ACRJ),U,2)
S ACRSEQ=$P(ACRDATA(ACRJ),U,3)
S ACRNAM=$E($P(^ACRAPVT(ACRAPDA,0),U),1,23)
W !,$J(ACRJ,2),") "
W ?5,ACRSEQ
W ?9,ACRNAM
K ACRNAM
W:$D(ACRDATA(ACRJ,"Y")) ?34,"FINAL"
Q:'$D(ACRDATA(ACRJ+12))
S ACRJJ=ACRJ+12
S ACRAPDA=$P(ACRDATA(ACRJJ),U,2)
S ACRSEQ=$P(ACRDATA(ACRJJ),U,3)
S ACRNAM=$E($P(^ACRAPVT(ACRAPDA,0),U),1,23)
W ?40,$J(ACRJJ,2),") "
W ?45,ACRSEQ
W ?49,ACRNAM K ACRNAM
W:$D(ACRDATA(ACRJJ,"Y")) ?75,"FINAL"
Q
SET S DIR(0)="LOA^1:"_ACRSET
S DIR("A")="New Sequence for "_ACRREFC_": "
W !
D DIR^ACRFDIC
Q:$D(ACRQUIT)!$D(ACROUT)
F ACRI=1:1:$L(X) D
.S ACRX=$E(X,ACRI)
.I ACRX'?1N.N&(ACRX'?1",")&(ACRX'?1"-") D
..W *7
..W ?$X+1,"??"
..G SET
S ACRX=Y(0)
S ACRCNT=$L(ACRX,",")-1
F ACRJ=1:1 S ACRXX=$P(ACRX,",",ACRJ) Q:ACRXX="" D
.S ACRDATA(ACRXX)=$P(ACRDATA(ACRXX),U,1,2)_U_ACRJ
.S ACRDATA1(ACRXX)=ACRDATA(ACRXX)
.S:$L(ACRX,",")-1=ACRJ $P(ACRDATA1(ACRXX),U,4)="Y"
K ACRCNT,ACRXX,ACRX
S ACRX=0
F S ACRX=$O(^ACRDOCA("B",ACRRCDA,ACRX)) Q:'ACRX D:$P(^ACRDOCA(ACRX,0),U,6)=ACRADA S2
S ACRX=0
F S ACRX=$O(ACRDATA1(ACRX)) Q:'ACRX D S3
K ACRDATA,ACRDATA1,ACRAPDA,ACRX
Q
D1 S ACRDATA(ACRJ)=ACRRCDA_U_ACRY_U
S (ACRMAX,ACRSET)=ACRJ
Q
S1 S ACRXX=$P(ACRX,",",ACRJ)
S ACRDATA(ACRXX)=ACRDATA(ACRXX)_ACRJ
S ACRDATA1(ACRXX)=ACRDATA(ACRXX)
Q
S2 S DA=ACRX
S DIK="^ACRDOCA("
D DIK^ACRFDIC
Q
S3 S DIC="^ACRDOCA("
S DIC(0)="L"
S X=+ACRDATA1(ACRX)
S DIC("DR")=".02////"_$P(ACRDATA1(ACRX),U,2)_";.03////"_$P(ACRDATA1(ACRX),U,3)_";.06////"_ACRADA
S:$P(ACRDATA1(ACRX),U,4)="Y" DIC("DR")=DIC("DR")_";.04////Y"
D FILE^ACRFDIC
Q
ACRTT ;EP;
S ACRTT=""
D EN
K ACRTT
Q
NEWSU ;COPY APPROVALS FROM EACRDAISTING PATTERN
W *7,*7
W !!,"There don't appear to be any signature sequences on file for this Area Setup."
W !,"Signature sequences from the primary system will now be duplicte."
D WAIT^DICD
N Y
S ACRDA=0
F S ACRDA=$O(^ACRDOCA(ACRDA)) Q:'ACRDA I $D(^ACRDOCA(ACRDA,0)),$P(^(0),U,6)=1 S Y=^(0) D
.S X=+Y
.S DIC="^ACRDOCA("
.S DIC(0)="L"
.S DIC("DR")=".02////"_$P(Y,U,2)_";.03////"_$P(Y,U,3)_";.04////"_$P(Y,U,4)_";30////"_$P(Y,U,5)_";.06////"_ACRADA
.D FILE^ACRFDIC
Q
ACRFDRCL ;IHS/OIRM/DSD/THL,AEF - REQUEST TYPE SEQUENCE CONTROL; [ 11/01/2001 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
+2 ;;ROUTINE USED TO ESTABLISH AND CHANGE REQUEST TYPE APPROVAL
+3 ;;SEQUENCE CONTROL
EN SET DIC(0)="AEMQZ"
+1 DO AREA^ACRFAS
+2 IF $DATA(ACRQUIT)!'$GET(ACRADA)
QUIT
+3 IF '$DATA(^ACRDOCA("AC",ACRADA))
DO NEWSU
+4 FOR
DO EN1
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
EXIT KILL ACRDATA,ACRDATA1,ACRQUIT,ACRSET,ACRJ,ACRMAX,ACRREFC,ACRTT,ACRCAT,ACRI,ACRJJ,ACRORDR,ACRTX,ACRTXNAM,ACRJJJ
+1 QUIT
EN1 DO SELECT
IF '$DATA(ACRQUIT)
DO LOCATION
+1 QUIT
SELECT SET ACRXDRCL="ESTABLISH APPROVAL SEQUENCE FOR: "_$PIECE(^AUTTAREA(+^ACRSYS(ACRADA,0),0),U)
+1 SET ACRSET=""
+2 DO DISPLAY^ACRFTXTP
+3 KILL ACRXDRCL
+4 SET DIR(0)="NOA^1:"_ACRJ_"^K:X'?1N.2N!(X<1)!(X>ACRJ) X"
+5 SET DIR("A")="Which one ==> "
+6 WRITE !
+7 DO DIR^ACRFDIC
+8 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+9 SET (ACRRCDA,DA)=+ACRTX(X)
+10 SET ACRCAT=$PIECE(ACRTX(X),U,6)
+11 SET ACRREFC=$PIECE(^ACRTXTYP(DA,0),U)
+12 QUIT
LOCATION FOR
DO DISPLAY
DO SET
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+1 KILL ACRQUIT
+2 QUIT
DISPLAY WRITE @IOF
+1 WRITE !!?9,"APPROVAL SEQUENCE FOR: ",@ACRON,ACRREFC,@ACROF
+2 WRITE !!,"NO. SEQ"
+3 WRITE ?9,"APPROVAL CATEGORY"
+4 WRITE ?40,"NO. SEQ"
+5 WRITE ?49,"APPROVAL CATEGORY"
+6 WRITE !,"--- --- -------------------------"
+7 WRITE ?40,"--- --- -------------------------"
+8 NEW ACRY
+9 SET ACRY=0
+10 KILL ACRDATA
+11 FOR ACRJ=1:1
SET ACRY=$ORDER(^ACRAPVT("C",ACRCAT,ACRY))
IF 'ACRY
QUIT
Begin DoDot:1
+12 SET ACRORDR=$PIECE(^ACRAPVT(ACRY,0),U,4)
+13 SET ACRDATA(100+ACRORDR)=ACRRCDA_U_ACRY_U
+14 SET (ACRMAX,ACRSET)=ACRJ
End DoDot:1
+15 SET ACRDATA(100+ACRJ)=ACRRCDA_U_(19)_U
+16 SET ACRDATA(100+ACRJ+1)=ACRRCDA_U_15_U
+17 SET ACRSET=ACRJ+1
+18 DO DD1
+19 SET ACRJ=0
+20 SET ACRMAX=ACRMAX+(ACRMAX#2)
+21 FOR
SET ACRJ=$ORDER(ACRDATA(ACRJ))
IF ACRJ>12!('ACRJ)
QUIT
DO DISP1
+22 KILL ACRX,ACRSEQ,ACRAPDA
+23 QUIT
DD1 SET ACRJ=100
+1 SET ACRMAX=0
+2 FOR
SET ACRJ=$ORDER(ACRDATA(ACRJ))
IF 'ACRJ
QUIT
Begin DoDot:1
+3 SET ACRAPDA=$PIECE(ACRDATA(ACRJ),U,2)
+4 IF '$DATA(ACRDATA1)
IF $DATA(^ACRDOCA("AC",ACRADA,ACRRCDA,ACRAPDA))
SET ACRSEQ=$ORDER(^(ACRAPDA,""))
SET ACRSEQX=$ORDER(^(ACRSEQ,0))
IF $PIECE(^ACRDOCA(ACRSEQX,0),U,4)]""
SET ACRDATA(ACRSEQ,$PIECE(^(0),U,4))=""
+5 IF '$TEST
SET ACRSEQ=$PIECE($GET(ACRDATA1(ACRJ)),U,3)
+6 IF ACRSEQ
Begin DoDot:2
+7 SET ACRDATA(ACRSEQ)=ACRDATA(ACRJ)_ACRSEQ
Begin DoDot:3
End DoDot:3
+8 KILL ACRDATA(ACRJ)
+9 SET ACRMAX=$SELECT(ACRSEQ>ACRMAX:ACRSEQ,1:ACRMAX)
End DoDot:2
End DoDot:1
+10 SET ACRJ=100
+11 FOR
SET ACRJ=$ORDER(ACRDATA(ACRJ))
IF 'ACRJ
QUIT
Begin DoDot:1
+12 SET ACRMAX=ACRMAX+1
+13 SET ACRDATA(ACRMAX)=ACRDATA(ACRJ)
+14 KILL ACRDATA(ACRJ)
End DoDot:1
+15 QUIT
DISP1 SET ACRAPDA=$PIECE(ACRDATA(ACRJ),U,2)
+1 SET ACRSEQ=$PIECE(ACRDATA(ACRJ),U,3)
+2 SET ACRNAM=$EXTRACT($PIECE(^ACRAPVT(ACRAPDA,0),U),1,23)
+3 WRITE !,$JUSTIFY(ACRJ,2),") "
+4 WRITE ?5,ACRSEQ
+5 WRITE ?9,ACRNAM
+6 KILL ACRNAM
+7 IF $DATA(ACRDATA(ACRJ,"Y"))
WRITE ?34,"FINAL"
+8 IF '$DATA(ACRDATA(ACRJ+12))
QUIT
+9 SET ACRJJ=ACRJ+12
+10 SET ACRAPDA=$PIECE(ACRDATA(ACRJJ),U,2)
+11 SET ACRSEQ=$PIECE(ACRDATA(ACRJJ),U,3)
+12 SET ACRNAM=$EXTRACT($PIECE(^ACRAPVT(ACRAPDA,0),U),1,23)
+13 WRITE ?40,$JUSTIFY(ACRJJ,2),") "
+14 WRITE ?45,ACRSEQ
+15 WRITE ?49,ACRNAM
KILL ACRNAM
+16 IF $DATA(ACRDATA(ACRJJ,"Y"))
WRITE ?75,"FINAL"
+17 QUIT
SET SET DIR(0)="LOA^1:"_ACRSET
+1 SET DIR("A")="New Sequence for "_ACRREFC_": "
+2 WRITE !
+3 DO DIR^ACRFDIC
+4 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+5 FOR ACRI=1:1:$LENGTH(X)
Begin DoDot:1
+6 SET ACRX=$EXTRACT(X,ACRI)
+7 IF ACRX'?1N.N&(ACRX'?1",")&(ACRX'?1"-")
Begin DoDot:2
+8 WRITE *7
+9 WRITE ?$X+1,"??"
+10 GOTO SET
End DoDot:2
End DoDot:1
+11 SET ACRX=Y(0)
+12 SET ACRCNT=$LENGTH(ACRX,",")-1
+13 FOR ACRJ=1:1
SET ACRXX=$PIECE(ACRX,",",ACRJ)
IF ACRXX=""
QUIT
Begin DoDot:1
+14 SET ACRDATA(ACRXX)=$PIECE(ACRDATA(ACRXX),U,1,2)_U_ACRJ
+15 SET ACRDATA1(ACRXX)=ACRDATA(ACRXX)
+16 IF $LENGTH(ACRX,",")-1=ACRJ
SET $PIECE(ACRDATA1(ACRXX),U,4)="Y"
End DoDot:1
+17 KILL ACRCNT,ACRXX,ACRX
+18 SET ACRX=0
+19 FOR
SET ACRX=$ORDER(^ACRDOCA("B",ACRRCDA,ACRX))
IF 'ACRX
QUIT
IF $PIECE(^ACRDOCA(ACRX,0),U,6)=ACRADA
DO S2
+20 SET ACRX=0
+21 FOR
SET ACRX=$ORDER(ACRDATA1(ACRX))
IF 'ACRX
QUIT
DO S3
+22 KILL ACRDATA,ACRDATA1,ACRAPDA,ACRX
+23 QUIT
D1 SET ACRDATA(ACRJ)=ACRRCDA_U_ACRY_U
+1 SET (ACRMAX,ACRSET)=ACRJ
+2 QUIT
S1 SET ACRXX=$PIECE(ACRX,",",ACRJ)
+1 SET ACRDATA(ACRXX)=ACRDATA(ACRXX)_ACRJ
+2 SET ACRDATA1(ACRXX)=ACRDATA(ACRXX)
+3 QUIT
S2 SET DA=ACRX
+1 SET DIK="^ACRDOCA("
+2 DO DIK^ACRFDIC
+3 QUIT
S3 SET DIC="^ACRDOCA("
+1 SET DIC(0)="L"
+2 SET X=+ACRDATA1(ACRX)
+3 SET DIC("DR")=".02////"_$PIECE(ACRDATA1(ACRX),U,2)_";.03////"_$PIECE(ACRDATA1(ACRX),U,3)_";.06////"_ACRADA
+4 IF $PIECE(ACRDATA1(ACRX),U,4)="Y"
SET DIC("DR")=DIC("DR")_";.04////Y"
+5 DO FILE^ACRFDIC
+6 QUIT
ACRTT ;EP;
+1 SET ACRTT=""
+2 DO EN
+3 KILL ACRTT
+4 QUIT
NEWSU ;COPY APPROVALS FROM EACRDAISTING PATTERN
+1 WRITE *7,*7
+2 WRITE !!,"There don't appear to be any signature sequences on file for this Area Setup."
+3 WRITE !,"Signature sequences from the primary system will now be duplicte."
+4 DO WAIT^DICD
+5 NEW Y
+6 SET ACRDA=0
+7 FOR
SET ACRDA=$ORDER(^ACRDOCA(ACRDA))
IF 'ACRDA
QUIT
IF $DATA(^ACRDOCA(ACRDA,0))
IF $PIECE(^(0),U,6)=1
SET Y=^(0)
Begin DoDot:1
+8 SET X=+Y
+9 SET DIC="^ACRDOCA("
+10 SET DIC(0)="L"
+11 SET DIC("DR")=".02////"_$PIECE(Y,U,2)_";.03////"_$PIECE(Y,U,3)_";.04////"_$PIECE(Y,U,4)_";30////"_$PIECE(Y,U,5)_";.06////"_ACRADA
+12 DO FILE^ACRFDIC
End DoDot:1
+13 QUIT
