- 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
