ACRFAPVS ;IHS/OIRM/DSD/THL,AEF - SET APPROVAL SEQUENCE FOR EACH DOC; [ 10/4/2005 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
;;ROUTINE CONTROLS CREATION OF ALL APPROVAL SEQUENCES FOR DOCUMENTS
;;WHICH ARE SENT FOR APPROVAL
EN ;EP;TO KILL,CREATE AND UPDATE DOCUMENTS IN THE APPROVAL SEQUENCE
I $E($G(IOST),1,2)="C-",$D(^ACRAPVS("AB",ACRDOCDA)),'$D(ACRSCHK),"^103^210^349^326^"'[(U_ACRREF_U),'$D(ACRCHANG) D DISPLAY Q:$D(ACRQUIT)
I $P(^ACRDOC(ACRDOCDA,0),U,4)=35,$P($G(ACRDOC0),U,13) S ACRREFDA=$P(ACRDOC0,U,13)
E S ACRREFDA=$P(^ACRDOC(ACRDOCDA,0),U,13)
S ACRCANDA=$P(^ACRDOC(ACRDOCDA,"REQ"),U,10)
S ACRREF=$P(^AUTTDOCR(ACRREFDA,0),U)
D KILL:$D(^ACRAPVS("AB",ACRDOCDA))
D CREATE
D UP^ACRFPRC3
EXIT K ACRORDER,ACRAPDA,ACRTYPDA,ACRTX,ACRFINAL,ACRGLB,ACRPC,ACRSDBUS
Q
CREATE ;CREATES NEW APPROVALS FOR A DOCUMENT
S ACRDOC0=^ACRDOC(ACRDOCDA,0)
S ACRLBDA=$P(ACRDOC0,U,6)
I ACRREFX=130,$E(^ACROBL(ACRDOCDA,"APV"))="A",$P(^("APV"),U)="A" S ACRREFX=600
I ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)!(ACRREFX=600) S ACRTX=$S(ACRREFX=600:19,1:11)
E D
.S ACRTX=$P(ACRDOC0,U,4)
.S ACRTX=$S($P(ACRDOC0,U,19):31,1:ACRTX)
I '$G(ACRADA) D Q:'$G(ACRADA)
.I $G(ACRPODA) S ACRADA=$P(^ACRPO(ACRPODA,0),U,19)
.I '$G(ACRPODA) D
..S ACRPODA=$P(ACRDOC0,U,8)
..S:ACRPODA ACRADA=$P(^ACRPO(ACRPODA,0),U,19)
..S:'ACRADA ACRADA=1
S ACRAPVT=0
F S ACRAPVT=$O(^ACRDOCA("AC",ACRADA,ACRTX,ACRAPVT)) Q:'ACRAPVT D
.I ACRAPVT=46!(ACRAPVT=1) D SADBUS I '$D(ACRSDBUS),ACRAPVT=46 Q
.I ACRAPVT=33!(ACRAPVT=34),$P(^AUTTCAN(ACRCANDA,0),U,3)'=1 Q
.S ACRORDER=$O(^ACRDOCA("AC",ACRADA,ACRTX,ACRAPVT,""))
.S ACRTYPDA=$O(^ACRDOCA("AC",ACRADA,ACRTX,ACRAPVT,ACRORDER,""))
.S ACRFINAL=$P(^ACRDOCA(ACRTYPDA,0),U,4)
.S ACRGLB=$P(^ACRAPVT(ACRAPVT,"DT"),U)
.S ACRPC=$P(^ACRAPVT(ACRAPVT,"DT"),U,2)
.S ACRUSER=$P($G(^ACRDOC(ACRDOCDA,ACRGLB)),U,ACRPC)
.I ACRAPVT=1,'$D(ACRSDBUS) S ACRORDER=1
.I ACRTX=35,ACRFINAL="Y" D
..D PROP
..S:$D(ACRPROP) ACRPROP=ACRORDER,ACRORDER=ACRORDER+2
.D SETAPP
; Hardcode approval signature sequence for Property Clearance and Local Property Manager on 3100 CC requests
I $D(ACRPROP) D
.F ACRORDER=ACRPROP
.; Property Clearance
.S ACRAPVT=31
.S ACRFINAL=""
.S ACRGLB=$P(^ACRAPVT(ACRAPVT,"DT"),U)
.S ACRPC=$P(^ACRAPVT(ACRAPVT,"DT"),U,2)
.S ACRUSER=$P($G(^ACRDOC(ACRDOCDA,ACRGLB)),U,ACRPC)
.D SETAPP
.K ACRPROP ; ACR*2.1*19.06 IM18610
.Q ; ACR*2.1*19.06 IM18610
.S ACRORDER=ACRPROP+1
.; Local Property Manager
.S ACRAPVT=6
.S ACRFINAL=""
.S ACRGLB=$P(^ACRAPVT(ACRAPVT,"DT"),U)
.S ACRPC=$P(^ACRAPVT(ACRAPVT,"DT"),U,2)
.S ACRUSER=$P($G(^ACRDOC(ACRDOCDA,ACRGLB)),U,ACRPC)
.D SETAPP
.K ACRPROP
Q
SETAPP ;EP;TO CREATE APPROVAL ENTRY
S X=ACRDOCDA
S DIC="^ACRAPVS("
S DIC(0)="L"
S DIC("DR")="5////"_ACRFINAL_";.03////"_ACRAPVT_";.04////"_ACRORDER_";.05////"_ACRLBDA_";.06////"_ACRREFDA_";2////"_$S(ACRUSER:ACRUSER,1:"")_";.08////"_DUZ
S:$D(ACRDATE) DIC("DR")=DIC("DR")_";3////"_ACRDATE
S:$D(ACRRDATE) DIC("DR")=DIC("DR")_";8////"_ACRRDATE
S:$D(ACRRRNO) DIC("DR")=DIC("DR")_";9////"_ACRRRNO
K ACRORDER,ACRTYPDA,ACRGLB,ACRPC
I ACRAPVT=41 D I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q
.N ACRAPDA
.S ACRAPDA=0
.F S ACRAPDA=$O(^ACRAPVS("ANXT",ACRAPVT,ACRUSER,ACRAPDA)) Q:'ACRAPDA I ^(ACRAPDA)=ACRDOCDA S ACRQUIT="" Q
D FILE^ACRFDIC
Q
KILL ;EP;TO KILL EXISTING APPROVALS FOR A DOCUMENT
N ACRAPVT,ACRINDV,ACRAPDA,X,Y
S ACRAPDA=0
S DIK="^ACRAPVS("
F S ACRAPDA=$O(^ACRAPVS("AB",ACRDOCDA,ACRAPDA)) Q:'ACRAPDA D
.I '$D(^ACRAPVS(ACRAPDA,0))!'$D(^ACRAPVS(ACRAPDA,"DT")) D Q
..K ^ACRAPVS(ACRAPDA,"DT")
..K ^ACRAPVS(ACRAPDA,0),^ACRAPVS("AB",ACRDOCDA,ACRAPDA)
.S X=^ACRAPVS(ACRAPDA,0)
.S Y=^ACRAPVS(ACRAPDA,"DT")
.Q:ACRREFDA'=$P(X,U,6)
.S ACRAPVT=$P(X,U,3)
.S ACRORD=$P(X,U,4)
.S ACRINDV=$P(Y,U,2)
.K ^ACRAPVS("ANXT",+ACRAPVT,+ACRINDV,+ACRAPDA)
.D NOW^%DTC
.S DA=ACRAPDA
.S DIE="^ACRAPVS("
.S DR=".07////"_ACRDOCDA_";.1////"_%_";.09////"_DUZ
.D DIE^ACRFDIC
.K ^ACRAPVS("AB",ACRDOCDA,+ACRAPDA)
.K ^ACRAPVS("AORDR",ACRDOCDA,+ACRORD,+ACRAPDA)
.K ^ACRAPVS("AC",ACRDOCDA,+ACRINDV,+ACRAPDA)
.K ACRAPVT,ACRORD
K ^ACRAPVS("AORDR",ACRDOCDA)
I $D(^ACRTVAL(ACRDOCDA)) D
. S DA=ACRDOCDA
. S DIE="^ACRTVAL("
. S DR=".04///^S X=""@"""
. D ^DIE
Q
SADBUS ;EP;TO DETERMIN IF SADBUS SIGNATURE IS REQUIRED
N X
S X=$E($P(^ACRDOC(ACRDOCDA,"PO"),U,2))
Q:X="G"!(X="V")
I $P($G(^ACRDOC(ACRDOCDA,"PO")),U,5),$D(^AUTTVNDR($P(^("PO"),U,5),11)),$P(^(11),U,27)="A1" Q
N X,Y
S (X,Y)=0
F S X=$O(^ACRSS("J",ACRDOCDA,X)) Q:'X S Y=Y+$P($G(^ACRSS(X,"DT")),U,4)
S:Y>2499.9999 ACRSDBUS=""
Q
DISPLAY ;DISPLAY APPROVALS PRIOR TO KILLING AND RECREATING APPROVALS
K ACRQUIT
N X
S X=0
F S X=$O(^ACRAPVS("AB",ACRDOCDA,X)) Q:'X I $G(ACRREFDA)=$P($G(^ACRAPVS(X,0)),U,6) S ACRQUIT="" Q
Q:'$D(ACRQUIT)
K ACRQUIT
D ^ACRFPAPV
S DIR(0)="YO"
S DIR("A",1)="Are you certain you want to send"
S DIR("A")="this document for approval"
S DIR("B")="NO"
W !!,"Sending this document for approval will delete any approvals currently listed."
W !
D DIR^ACRFDIC
I $G(Y)'=1 S ACRQUIT=""
Q
PROP ;DETERMINE IF CREDIT CARD ITEMS INCLUDE EQUIPMENT AND INCLUDE
;PROPERTY MGT SIGNATURE IF SO
K ACRPROP
N X,Y
S X=0
F S X=$O(^ACRSS($S(ACRREFX=116&($P(^ACRDOC(ACRDOCDA,0),U,4)'=35):"C",ACRREFX=116&($P(^ACRDOC(ACRDOCDA,0),U,4)=35&($P($G(^ACROBL(ACRDOCDA,"APV")),U)'="A")):"C",1:"J"),ACRDOCDA,X)) Q:'X D
.S Y=$P($G(^ACRSS(X,0)),U,4)
.S Y=$P($G(^AUTTOBJC(+Y,0)),U)
.I $E(Y,1,2)=31 S ACRPROP=""
Q
ACRFAPVS ;IHS/OIRM/DSD/THL,AEF - SET APPROVAL SEQUENCE FOR EACH DOC; [ 10/4/2005 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
+2 ;;ROUTINE CONTROLS CREATION OF ALL APPROVAL SEQUENCES FOR DOCUMENTS
+3 ;;WHICH ARE SENT FOR APPROVAL
EN ;EP;TO KILL,CREATE AND UPDATE DOCUMENTS IN THE APPROVAL SEQUENCE
+1 IF $EXTRACT($GET(IOST),1,2)="C-"
IF $DATA(^ACRAPVS("AB",ACRDOCDA))
IF '$DATA(ACRSCHK)
IF "^103^210^349^326^"'[(U_ACRREF_U)
IF '$DATA(ACRCHANG)
DO DISPLAY
IF $DATA(ACRQUIT)
QUIT
+2 IF $PIECE(^ACRDOC(ACRDOCDA,0),U,4)=35
IF $PIECE($GET(ACRDOC0),U,13)
SET ACRREFDA=$PIECE(ACRDOC0,U,13)
+3 IF '$TEST
SET ACRREFDA=$PIECE(^ACRDOC(ACRDOCDA,0),U,13)
+4 SET ACRCANDA=$PIECE(^ACRDOC(ACRDOCDA,"REQ"),U,10)
+5 SET ACRREF=$PIECE(^AUTTDOCR(ACRREFDA,0),U)
+6 IF $DATA(^ACRAPVS("AB",ACRDOCDA))
DO KILL
+7 DO CREATE
+8 DO UP^ACRFPRC3
EXIT KILL ACRORDER,ACRAPDA,ACRTYPDA,ACRTX,ACRFINAL,ACRGLB,ACRPC,ACRSDBUS
+1 QUIT
CREATE ;CREATES NEW APPROVALS FOR A DOCUMENT
+1 SET ACRDOC0=^ACRDOC(ACRDOCDA,0)
+2 SET ACRLBDA=$PIECE(ACRDOC0,U,6)
+3 IF ACRREFX=130
IF $EXTRACT(^ACROBL(ACRDOCDA,"APV"))="A"
IF $PIECE(^("APV"),U)="A"
SET ACRREFX=600
+4 IF ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)!(ACRREFX=600)
SET ACRTX=$SELECT(ACRREFX=600:19,1:11)
+5 IF '$TEST
Begin DoDot:1
+6 SET ACRTX=$PIECE(ACRDOC0,U,4)
+7 SET ACRTX=$SELECT($PIECE(ACRDOC0,U,19):31,1:ACRTX)
End DoDot:1
+8 IF '$GET(ACRADA)
Begin DoDot:1
+9 IF $GET(ACRPODA)
SET ACRADA=$PIECE(^ACRPO(ACRPODA,0),U,19)
+10 IF '$GET(ACRPODA)
Begin DoDot:2
+11 SET ACRPODA=$PIECE(ACRDOC0,U,8)
+12 IF ACRPODA
SET ACRADA=$PIECE(^ACRPO(ACRPODA,0),U,19)
+13 IF 'ACRADA
SET ACRADA=1
End DoDot:2
End DoDot:1
IF '$GET(ACRADA)
QUIT
+14 SET ACRAPVT=0
+15 FOR
SET ACRAPVT=$ORDER(^ACRDOCA("AC",ACRADA,ACRTX,ACRAPVT))
IF 'ACRAPVT
QUIT
Begin DoDot:1
+16 IF ACRAPVT=46!(ACRAPVT=1)
DO SADBUS
IF '$DATA(ACRSDBUS)
IF ACRAPVT=46
QUIT
+17 IF ACRAPVT=33!(ACRAPVT=34)
IF $PIECE(^AUTTCAN(ACRCANDA,0),U,3)'=1
QUIT
+18 SET ACRORDER=$ORDER(^ACRDOCA("AC",ACRADA,ACRTX,ACRAPVT,""))
+19 SET ACRTYPDA=$ORDER(^ACRDOCA("AC",ACRADA,ACRTX,ACRAPVT,ACRORDER,""))
+20 SET ACRFINAL=$PIECE(^ACRDOCA(ACRTYPDA,0),U,4)
+21 SET ACRGLB=$PIECE(^ACRAPVT(ACRAPVT,"DT"),U)
+22 SET ACRPC=$PIECE(^ACRAPVT(ACRAPVT,"DT"),U,2)
+23 SET ACRUSER=$PIECE($GET(^ACRDOC(ACRDOCDA,ACRGLB)),U,ACRPC)
+24 IF ACRAPVT=1
IF '$DATA(ACRSDBUS)
SET ACRORDER=1
+25 IF ACRTX=35
IF ACRFINAL="Y"
Begin DoDot:2
+26 DO PROP
+27 IF $DATA(ACRPROP)
SET ACRPROP=ACRORDER
SET ACRORDER=ACRORDER+2
End DoDot:2
+28 DO SETAPP
End DoDot:1
+29 ; Hardcode approval signature sequence for Property Clearance and Local Property Manager on 3100 CC requests
+30 IF $DATA(ACRPROP)
Begin DoDot:1
+31 FOR ACRORDER=ACRPROP
+32 ; Property Clearance
+33 SET ACRAPVT=31
+34 SET ACRFINAL=""
+35 SET ACRGLB=$PIECE(^ACRAPVT(ACRAPVT,"DT"),U)
+36 SET ACRPC=$PIECE(^ACRAPVT(ACRAPVT,"DT"),U,2)
+37 SET ACRUSER=$PIECE($GET(^ACRDOC(ACRDOCDA,ACRGLB)),U,ACRPC)
+38 DO SETAPP
+39 ; ACR*2.1*19.06 IM18610
KILL ACRPROP
+40 ; ACR*2.1*19.06 IM18610
QUIT
+41 SET ACRORDER=ACRPROP+1
+42 ; Local Property Manager
+43 SET ACRAPVT=6
+44 SET ACRFINAL=""
+45 SET ACRGLB=$PIECE(^ACRAPVT(ACRAPVT,"DT"),U)
+46 SET ACRPC=$PIECE(^ACRAPVT(ACRAPVT,"DT"),U,2)
+47 SET ACRUSER=$PIECE($GET(^ACRDOC(ACRDOCDA,ACRGLB)),U,ACRPC)
+48 DO SETAPP
+49 KILL ACRPROP
End DoDot:1
+50 QUIT
SETAPP ;EP;TO CREATE APPROVAL ENTRY
+1 SET X=ACRDOCDA
+2 SET DIC="^ACRAPVS("
+3 SET DIC(0)="L"
+4 SET DIC("DR")="5////"_ACRFINAL_";.03////"_ACRAPVT_";.04////"_ACRORDER_";.05////"_ACRLBDA_";.06////"_ACRREFDA_";2////"_$SELECT(ACRUSER:ACRUSER,1:"")_";.08////"_DUZ
+5 IF $DATA(ACRDATE)
SET DIC("DR")=DIC("DR")_";3////"_ACRDATE
+6 IF $DATA(ACRRDATE)
SET DIC("DR")=DIC("DR")_";8////"_ACRRDATE
+7 IF $DATA(ACRRRNO)
SET DIC("DR")=DIC("DR")_";9////"_ACRRRNO
+8 KILL ACRORDER,ACRTYPDA,ACRGLB,ACRPC
+9 IF ACRAPVT=41
Begin DoDot:1
+10 NEW ACRAPDA
+11 SET ACRAPDA=0
+12 FOR
SET ACRAPDA=$ORDER(^ACRAPVS("ANXT",ACRAPVT,ACRUSER,ACRAPDA))
IF 'ACRAPDA
QUIT
IF ^(ACRAPDA)=ACRDOCDA
SET ACRQUIT=""
QUIT
End DoDot:1
IF $DATA(ACRQUIT)!$DATA(ACROUT)
KILL ACRQUIT
QUIT
+13 DO FILE^ACRFDIC
+14 QUIT
KILL ;EP;TO KILL EXISTING APPROVALS FOR A DOCUMENT
+1 NEW ACRAPVT,ACRINDV,ACRAPDA,X,Y
+2 SET ACRAPDA=0
+3 SET DIK="^ACRAPVS("
+4 FOR
SET ACRAPDA=$ORDER(^ACRAPVS("AB",ACRDOCDA,ACRAPDA))
IF 'ACRAPDA
QUIT
Begin DoDot:1
+5 IF '$DATA(^ACRAPVS(ACRAPDA,0))!'$DATA(^ACRAPVS(ACRAPDA,"DT"))
Begin DoDot:2
+6 KILL ^ACRAPVS(ACRAPDA,"DT")
+7 KILL ^ACRAPVS(ACRAPDA,0),^ACRAPVS("AB",ACRDOCDA,ACRAPDA)
End DoDot:2
QUIT
+8 SET X=^ACRAPVS(ACRAPDA,0)
+9 SET Y=^ACRAPVS(ACRAPDA,"DT")
+10 IF ACRREFDA'=$PIECE(X,U,6)
QUIT
+11 SET ACRAPVT=$PIECE(X,U,3)
+12 SET ACRORD=$PIECE(X,U,4)
+13 SET ACRINDV=$PIECE(Y,U,2)
+14 KILL ^ACRAPVS("ANXT",+ACRAPVT,+ACRINDV,+ACRAPDA)
+15 DO NOW^%DTC
+16 SET DA=ACRAPDA
+17 SET DIE="^ACRAPVS("
+18 SET DR=".07////"_ACRDOCDA_";.1////"_%_";.09////"_DUZ
+19 DO DIE^ACRFDIC
+20 KILL ^ACRAPVS("AB",ACRDOCDA,+ACRAPDA)
+21 KILL ^ACRAPVS("AORDR",ACRDOCDA,+ACRORD,+ACRAPDA)
+22 KILL ^ACRAPVS("AC",ACRDOCDA,+ACRINDV,+ACRAPDA)
+23 KILL ACRAPVT,ACRORD
End DoDot:1
+24 KILL ^ACRAPVS("AORDR",ACRDOCDA)
+25 IF $DATA(^ACRTVAL(ACRDOCDA))
Begin DoDot:1
+26 SET DA=ACRDOCDA
+27 SET DIE="^ACRTVAL("
+28 SET DR=".04///^S X=""@"""
+29 DO ^DIE
End DoDot:1
+30 QUIT
SADBUS ;EP;TO DETERMIN IF SADBUS SIGNATURE IS REQUIRED
+1 NEW X
+2 SET X=$EXTRACT($PIECE(^ACRDOC(ACRDOCDA,"PO"),U,2))
+3 IF X="G"!(X="V")
QUIT
+4 IF $PIECE($GET(^ACRDOC(ACRDOCDA,"PO")),U,5)
IF $DATA(^AUTTVNDR($PIECE(^("PO"),U,5),11))
IF $PIECE(^(11),U,27)="A1"
QUIT
+5 NEW X,Y
+6 SET (X,Y)=0
+7 FOR
SET X=$ORDER(^ACRSS("J",ACRDOCDA,X))
IF 'X
QUIT
SET Y=Y+$PIECE($GET(^ACRSS(X,"DT")),U,4)
+8 IF Y>2499.9999
SET ACRSDBUS=""
+9 QUIT
DISPLAY ;DISPLAY APPROVALS PRIOR TO KILLING AND RECREATING APPROVALS
+1 KILL ACRQUIT
+2 NEW X
+3 SET X=0
+4 FOR
SET X=$ORDER(^ACRAPVS("AB",ACRDOCDA,X))
IF 'X
QUIT
IF $GET(ACRREFDA)=$PIECE($GET(^ACRAPVS(X,0)),U,6)
SET ACRQUIT=""
QUIT
+5 IF '$DATA(ACRQUIT)
QUIT
+6 KILL ACRQUIT
+7 DO ^ACRFPAPV
+8 SET DIR(0)="YO"
+9 SET DIR("A",1)="Are you certain you want to send"
+10 SET DIR("A")="this document for approval"
+11 SET DIR("B")="NO"
+12 WRITE !!,"Sending this document for approval will delete any approvals currently listed."
+13 WRITE !
+14 DO DIR^ACRFDIC
+15 IF $GET(Y)'=1
SET ACRQUIT=""
+16 QUIT
PROP ;DETERMINE IF CREDIT CARD ITEMS INCLUDE EQUIPMENT AND INCLUDE
+1 ;PROPERTY MGT SIGNATURE IF SO
+2 KILL ACRPROP
+3 NEW X,Y
+4 SET X=0
+5 FOR
SET X=$ORDER(^ACRSS($SELECT(ACRREFX=116&($PIECE(^ACRDOC(ACRDOCDA,0),U,4)'=35):"C",ACRREFX=116&($PIECE(^ACRDOC(ACRDOCDA,0),U,4)=35&($PIECE($GET(^ACROBL(ACRDOCDA,"APV")),U)'="A")):"C",1:"J"),ACRDOCDA,X))
IF 'X
QUIT
Begin DoDot:1
+6 SET Y=$PIECE($GET(^ACRSS(X,0)),U,4)
+7 SET Y=$PIECE($GET(^AUTTOBJC(+Y,0)),U)
+8 IF $EXTRACT(Y,1,2)=31
SET ACRPROP=""
End DoDot:1
+9 QUIT
