ACRFDEL ;IHS/OIRM/DSD/THL,AEF - CANCEL A REQUEST; [ 11/01/2001 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
;;ROUTINE USED TO MANAGE TRANSFER OF REQUEST FROM ONE ACCOUNT TO
;;ANOTHER AND TO CANCEL OR DELETE A REQUEST
EN ;EP;TO CANCEL OR TRANSFER A REQUEST
D EN1
EXIT K ACRDOCDA,ACRDOCDA,DA,ACRDOC,ACRID,ACRFDNO,ACRTDEL,ACRLBDA,ACRTREQ,ACRTOBL,ACRREQ,ACROBL
Q
EN1 ;SELECT TO CANCEL OR TRANSFER REQUEST
I $D(ACRJVOD) D JVOD Q
S DIR(0)="SO^1:Delete "_ACRDOC_" ("_ACRID_")"_";2:Transfer "_ACRDOC_" ("_ACRID_")"
D DIR^ACRFDIC
I Y=1 D EN2 Q
I Y=2 D T
Q
EN2 ;EP;CANCEL A REQUEST
S DIR(0)="YO"
S DIR("A")="Are you certain you want to "_$S('$D(ACRCANCL):"delete",1:"cancel")_" "_ACRDOC_" ("_ACRID_")"
S DIR("B")="NO"
W !
D DIR^ACRFDIC
I Y'=1 K ACGQUIT Q
I ACRREF=103!(ACRREF=210&($P($G(^ACROBL(ACRDOCDA,"APV")),U,8)="A")) D CANPO
EN3 ;EP;
D WAIT^DICD:$E($G(IOST),1,2)="C-"
D DHR:$P($G(^ACROBL(ACRDOCDA,"APV")),U)="A"
D SS
D APPROVE
D REQ
D DOC
W !!,*7,*7,$G(ACRDOC)," (",$G(ACRID),") has been "
W $S($G(ACRAPDAS)="D":"disapproved.",'$D(ACRCANCL):"deleted.",1:"cancelled.")
D PAUSE^ACRFWARN
Q
SS ;ZERO OUT ALL ASSOCIATED ITEMS ON REQUEST
N ACRDA
S ACRDA=0
F S ACRDA=$O(^ACRSS("C",ACRDOCDA,ACRDA)) Q:'ACRDA D
.S DA=ACRDA
.S DIE="^ACRSS("
.S DR="13////0;16////0;16.1////0;18////0"
.D DIE^ACRFDIC
Q:'$D(^ACRAL("E",ACRDOCDA))
N ACRALDA
S ACRALDA=0
F S ACRALDA=$O(^ACRAL("E",ACRDOCDA,ACRALDA)) Q:'ACRALDA D
.S DA=ACRALDA
.S DIE="^ACRAL("
.S DR="9////0"
.D DIE^ACRFDIC
Q
APPROVE ;INVALIDATE ALL ASSOCIATED APPROVALS
S ACRDA=0
F S ACRDA=$O(^ACRAPVS("AB",ACRDOCDA,ACRDA)) Q:'ACRDA D
.I $P(^ACRAPVS(ACRDA,0),U,3),$D(^("DT")),$P(^("DT"),U,2) K ^ACRAPVS("ANXT",$P(^(0),U,3),$P(^("DT"),U,2),ACRDA)
.K ^ACRAPVS("AB",ACRDOCDA,ACRDA)
.S ^ACRAPVS("D",ACRDOCDA,ACRDA)=""
.S DA=ACRDA
.S DIE="^ACRAPVS("
.S DR=".07////"_ACRDOCDA_";.08////"_DT_";.09////"_DUZ
.D DIE^ACRFDIC
Q
REQ ;PUT REQUEST IN 'DISAPPROVED' STATUS
S DA=ACRDOCDA
S DIE="^ACROBL("
S DR="903////"_$S('$D(ACRCANCL):"D",1:"C")
D DIE^ACRFDIC
Q
DOC ;PUT DOCUMENT IN DISAPPROVED STATUS
I '$D(^ACRDOC(ACRDOCDA,0)) D
.S X="CANCELLED"
.S DIC="^ACRDOC("
.S DIC(0)="L"
.S DINUM=ACRDOCDA
.D FILE^ACRFDIC
S DA=ACRDOCDA
S DIE="^ACRDOC("
S DR=".2///@;.14////"_$S($P($G(^ACRDOC(ACRDOCDA,0)),U,14)'["CANCELLED":"CANCELLED ",1:"")_$P($G(^(0)),U,14)
D DIE^ACRFDIC
S ^ACRDOC(ACRDOCDA,"DT")=""
Q
T ;EP;TO SELECT THE DOCUMENT TO TRANSFER
K ACRFDNO
S ACRTDEL=""
D OBLAMT^ACRFDTPE
Q
T1 ;EP;TO TRANSFER DOCUMENT FROM ONE FINANCIAL ACCOUNT TO ANOTHER
I ACRLBDA=ACRFDNO D Q
.W !!,"Transfer to the same account is unnecessary."
.H 2
.K ACRTDEL,ACRFDNO
.S ACRQUIT=""
W !!,@ACRON,ACRDOC," (",ACRID,")",@ACROF," will be transferred to the"
W !,@ACRON,$P(^ACRLOCB(ACRFDNO,0),U,12),@ACROF," account."
S DIR(0)="YO"
S DIR("A")="Sure this is what you want"
S DIR("B")="NO"
W !
D DIR^ACRFDIC
I Y'=1 S ACRQUIT="" Q
W !
D:$E($G(IOST),1,2)="C-" WAIT^DICD
I $D(ACRJVOD) D DHR
S ACRCANDA=$P(^ACRLOCB(ACRFDNO,"DT"),U,9)
S DA=ACRDOCDA
S DIE="^ACROBL("
S DR=".03////"_ACRFDNO_";.04////"_ACRCANDA
D DIE^ACRFDIC
S DA=ACRDOCDA
S DIE="^ACRDOC("
S DR=".06////"_ACRFDNO_";113100////"_ACRCANDA
D DIE^ACRFDIC
S (ACRDA,ACRTREQ,ACRTOBL)=0
F S ACRDA=$O(^ACRSS("C",ACRDOCDA,ACRDA)) Q:'ACRDA D
.S DA=ACRDA
.S DIE="^ACRSS("
.S DR=".06////"_ACRFDNO_";.05////"_ACRCANDA
.D DIE^ACRFDIC
.N X
.S X=$G(^ACRSS(ACRDA,"DT"))
.S ACRTREQ=ACRTREQ+$P(X,U,4)
.S ACRTOBL=ACRTOBL+$P(X,U,9)
I ACRTREQ!ACRTOBL D
.N X
.S X=$G(^ACRLOCB(ACRFDNO,"BA"))
.S ACRREQ=$P(X,U,2)+ACRTREQ
.S ACROBL=$P(X,U,5)+ACRTOBL
.S DA=ACRFDNO
.S DIE="^ACRLOCB("
.S DR="2////"_ACRREQ_";7////"_ACROBL
.D DIE^ACRFDIC
.S X=$G(^ACRLOCB(ACRLBDA,"BA"))
.S ACRREQ=$P(X,U,2)-ACRTREQ
.S ACROBL=$P(X,U,5)-ACRTOBL
.S DA=ACRLBDA
.S DIE="^ACRLOCB("
.S DR="2////"_ACRREQ_";7////"_ACROBL
.D DIE^ACRFDIC
K DIE,DA,DR
N X
S X=^ACRDOC(ACRDOCDA,0)
S ACRDOCX=$P(X,U)
S ACRREFDA=$P(X,U,13)
S ACRTXDA=$P(X,U,4)
S (ACRREF,ACRREFX)=$P(^AUTTDOCR(ACRREFDA,0),U)
I ACRREF'=130,ACRREF'=600 D I 1
.S ACRREFX=$S(ACRREF'=148:116,1:ACRREF)
.S ACRREFDA=$O(^AUTTDOCR("B",ACRREFX,0))
.D DOC^ACRFDOCN
E D TO^ACRFDOCN
S DA=ACRDOCDA
S DIE="^ACRDOC("
S DR=".01///"_ACRDOC_";.17////"_ACRDOCX
D DIE^ACRFDIC
D:'$D(ACRJVOD) ^ACRFAPVS
W !!,@ACRON,ACRDOCX," (",ACRID,")",@ACROF," has been transferred to the"
W !,@ACRON,$P(^ACRLOCB(ACRFDNO,0),U,12),@ACROF," account (ID NO.: ",ACRFDNO,")."
W !,"The new document number is ",@ACRON,ACRDOC,@ACROF," (ID NO.: ",ACRDOCDA,")."
D PAUSE^ACRFWARN
S ACRQUIT=""
Q
JVOD ;EP;TO JOURNAL VOUCHER OBLIGATED DOCUMENT
D T
Q
CANYO ;EP;TO CANCEL/DELETE YOUR OWN REQUEST
S DIC="^ACRDOC("
S DIC(0)="QEALM"
S DIC("A")="Requisition/Travel Order NO.: "
S D="B^C^G^J"
S DIC("S")="S ACRREFDA=$P(^ACRDOC(+Y,0),U,13),ACRREQ=$P(^(""REQ2""),U,8),ACRTO=$P($G(^(""TO"")),U,9),ACRAPV=$P($G(^ACROBL(+Y,""APV"")),U,8),ACRREF=$P(^AUTTDOCR(ACRREFDA,0),U),ACRYO=$S(""^116^204^103^210^""[(U_ACRREF_U):ACRREQ,1:ACRTO)"
S DIC("S")=DIC("S")_" I ACRYO=DUZ,ACRREF'=103,ACRAPV'=""A"""
W !,"Select the document you want to DELETE/CANCEL"
W !!
D MIX^ACRFDIC
Q:+Y<1
S ACRDOCDA=+Y
D SETDOC^ACRFEA1
CANYO1 ;EP;AFTER DOCUMENT HAS BEEN SELECTED
I ACRREF=600 S ACRCANCL=""
D EN2
K ACRCANCL
Q
CANPO Q
S DA=ACRDOCDA
S DIE="^ACRDOC("
S DR="1901T"
W !
D DIE^ACRFDIC
S ACRFDNO=ACRLBDA
S ACRCANDA=$P(^ACRLOCB(ACRLBDA,"DT"),U)
S ACRAMEND=""
D EN1^ACRFAUTO
Q
DHR ;
N X,Y
S X=0
F S X=$O(^ACRDHR("E",ACRDOCDA,X)) Q:'X S Y=$G(^ACRDHR(X,1)) I $P(Y,U,3,4)="050^1" S ACRQUIT="" Q
Q:'$D(ACRQUIT)
K ACRQUIT
S ACRTCODE="050"
S ACRRCODE=2
S ACRMCODE=$S($G(ACRMCODE):ACRMCODE,1:5)
D ^ACRFDHR
K ACRTCODE,ACRRCODE,ACRMCODE
Q
ACRFDEL ;IHS/OIRM/DSD/THL,AEF - CANCEL A REQUEST; [ 11/01/2001 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
+2 ;;ROUTINE USED TO MANAGE TRANSFER OF REQUEST FROM ONE ACCOUNT TO
+3 ;;ANOTHER AND TO CANCEL OR DELETE A REQUEST
EN ;EP;TO CANCEL OR TRANSFER A REQUEST
+1 DO EN1
EXIT KILL ACRDOCDA,ACRDOCDA,DA,ACRDOC,ACRID,ACRFDNO,ACRTDEL,ACRLBDA,ACRTREQ,ACRTOBL,ACRREQ,ACROBL
+1 QUIT
EN1 ;SELECT TO CANCEL OR TRANSFER REQUEST
+1 IF $DATA(ACRJVOD)
DO JVOD
QUIT
+2 SET DIR(0)="SO^1:Delete "_ACRDOC_" ("_ACRID_")"_";2:Transfer "_ACRDOC_" ("_ACRID_")"
+3 DO DIR^ACRFDIC
+4 IF Y=1
DO EN2
QUIT
+5 IF Y=2
DO T
+6 QUIT
EN2 ;EP;CANCEL A REQUEST
+1 SET DIR(0)="YO"
+2 SET DIR("A")="Are you certain you want to "_$SELECT('$DATA(ACRCANCL):"delete",1:"cancel")_" "_ACRDOC_" ("_ACRID_")"
+3 SET DIR("B")="NO"
+4 WRITE !
+5 DO DIR^ACRFDIC
+6 IF Y'=1
KILL ACGQUIT
QUIT
+7 IF ACRREF=103!(ACRREF=210&($PIECE($GET(^ACROBL(ACRDOCDA,"APV")),U,8)="A"))
DO CANPO
EN3 ;EP;
+1 IF $EXTRACT($GET(IOST),1,2)="C-"
DO WAIT^DICD
+2 IF $PIECE($GET(^ACROBL(ACRDOCDA,"APV")),U)="A"
DO DHR
+3 DO SS
+4 DO APPROVE
+5 DO REQ
+6 DO DOC
+7 WRITE !!,*7,*7,$GET(ACRDOC)," (",$GET(ACRID),") has been "
+8 WRITE $SELECT($GET(ACRAPDAS)="D":"disapproved.",'$DATA(ACRCANCL):"deleted.",1:"cancelled.")
+9 DO PAUSE^ACRFWARN
+10 QUIT
SS ;ZERO OUT ALL ASSOCIATED ITEMS ON REQUEST
+1 NEW ACRDA
+2 SET ACRDA=0
+3 FOR
SET ACRDA=$ORDER(^ACRSS("C",ACRDOCDA,ACRDA))
IF 'ACRDA
QUIT
Begin DoDot:1
+4 SET DA=ACRDA
+5 SET DIE="^ACRSS("
+6 SET DR="13////0;16////0;16.1////0;18////0"
+7 DO DIE^ACRFDIC
End DoDot:1
+8 IF '$DATA(^ACRAL("E",ACRDOCDA))
QUIT
+9 NEW ACRALDA
+10 SET ACRALDA=0
+11 FOR
SET ACRALDA=$ORDER(^ACRAL("E",ACRDOCDA,ACRALDA))
IF 'ACRALDA
QUIT
Begin DoDot:1
+12 SET DA=ACRALDA
+13 SET DIE="^ACRAL("
+14 SET DR="9////0"
+15 DO DIE^ACRFDIC
End DoDot:1
+16 QUIT
APPROVE ;INVALIDATE ALL ASSOCIATED APPROVALS
+1 SET ACRDA=0
+2 FOR
SET ACRDA=$ORDER(^ACRAPVS("AB",ACRDOCDA,ACRDA))
IF 'ACRDA
QUIT
Begin DoDot:1
+3 IF $PIECE(^ACRAPVS(ACRDA,0),U,3)
IF $DATA(^("DT"))
IF $PIECE(^("DT"),U,2)
KILL ^ACRAPVS("ANXT",$PIECE(^(0),U,3),$PIECE(^("DT"),U,2),ACRDA)
+4 KILL ^ACRAPVS("AB",ACRDOCDA,ACRDA)
+5 SET ^ACRAPVS("D",ACRDOCDA,ACRDA)=""
+6 SET DA=ACRDA
+7 SET DIE="^ACRAPVS("
+8 SET DR=".07////"_ACRDOCDA_";.08////"_DT_";.09////"_DUZ
+9 DO DIE^ACRFDIC
End DoDot:1
+10 QUIT
REQ ;PUT REQUEST IN 'DISAPPROVED' STATUS
+1 SET DA=ACRDOCDA
+2 SET DIE="^ACROBL("
+3 SET DR="903////"_$SELECT('$DATA(ACRCANCL):"D",1:"C")
+4 DO DIE^ACRFDIC
+5 QUIT
DOC ;PUT DOCUMENT IN DISAPPROVED STATUS
+1 IF '$DATA(^ACRDOC(ACRDOCDA,0))
Begin DoDot:1
+2 SET X="CANCELLED"
+3 SET DIC="^ACRDOC("
+4 SET DIC(0)="L"
+5 SET DINUM=ACRDOCDA
+6 DO FILE^ACRFDIC
End DoDot:1
+7 SET DA=ACRDOCDA
+8 SET DIE="^ACRDOC("
+9 SET DR=".2///@;.14////"_$SELECT($PIECE($GET(^ACRDOC(ACRDOCDA,0)),U,14)'["CANCELLED":"CANCELLED ",1:"")_$PIECE($GET(^(0)),U,14)
+10 DO DIE^ACRFDIC
+11 SET ^ACRDOC(ACRDOCDA,"DT")=""
+12 QUIT
T ;EP;TO SELECT THE DOCUMENT TO TRANSFER
+1 KILL ACRFDNO
+2 SET ACRTDEL=""
+3 DO OBLAMT^ACRFDTPE
+4 QUIT
T1 ;EP;TO TRANSFER DOCUMENT FROM ONE FINANCIAL ACCOUNT TO ANOTHER
+1 IF ACRLBDA=ACRFDNO
Begin DoDot:1
+2 WRITE !!,"Transfer to the same account is unnecessary."
+3 HANG 2
+4 KILL ACRTDEL,ACRFDNO
+5 SET ACRQUIT=""
End DoDot:1
QUIT
+6 WRITE !!,@ACRON,ACRDOC," (",ACRID,")",@ACROF," will be transferred to the"
+7 WRITE !,@ACRON,$PIECE(^ACRLOCB(ACRFDNO,0),U,12),@ACROF," account."
+8 SET DIR(0)="YO"
+9 SET DIR("A")="Sure this is what you want"
+10 SET DIR("B")="NO"
+11 WRITE !
+12 DO DIR^ACRFDIC
+13 IF Y'=1
SET ACRQUIT=""
QUIT
+14 WRITE !
+15 IF $EXTRACT($GET(IOST),1,2)="C-"
DO WAIT^DICD
+16 IF $DATA(ACRJVOD)
DO DHR
+17 SET ACRCANDA=$PIECE(^ACRLOCB(ACRFDNO,"DT"),U,9)
+18 SET DA=ACRDOCDA
+19 SET DIE="^ACROBL("
+20 SET DR=".03////"_ACRFDNO_";.04////"_ACRCANDA
+21 DO DIE^ACRFDIC
+22 SET DA=ACRDOCDA
+23 SET DIE="^ACRDOC("
+24 SET DR=".06////"_ACRFDNO_";113100////"_ACRCANDA
+25 DO DIE^ACRFDIC
+26 SET (ACRDA,ACRTREQ,ACRTOBL)=0
+27 FOR
SET ACRDA=$ORDER(^ACRSS("C",ACRDOCDA,ACRDA))
IF 'ACRDA
QUIT
Begin DoDot:1
+28 SET DA=ACRDA
+29 SET DIE="^ACRSS("
+30 SET DR=".06////"_ACRFDNO_";.05////"_ACRCANDA
+31 DO DIE^ACRFDIC
+32 NEW X
+33 SET X=$GET(^ACRSS(ACRDA,"DT"))
+34 SET ACRTREQ=ACRTREQ+$PIECE(X,U,4)
+35 SET ACRTOBL=ACRTOBL+$PIECE(X,U,9)
End DoDot:1
+36 IF ACRTREQ!ACRTOBL
Begin DoDot:1
+37 NEW X
+38 SET X=$GET(^ACRLOCB(ACRFDNO,"BA"))
+39 SET ACRREQ=$PIECE(X,U,2)+ACRTREQ
+40 SET ACROBL=$PIECE(X,U,5)+ACRTOBL
+41 SET DA=ACRFDNO
+42 SET DIE="^ACRLOCB("
+43 SET DR="2////"_ACRREQ_";7////"_ACROBL
+44 DO DIE^ACRFDIC
+45 SET X=$GET(^ACRLOCB(ACRLBDA,"BA"))
+46 SET ACRREQ=$PIECE(X,U,2)-ACRTREQ
+47 SET ACROBL=$PIECE(X,U,5)-ACRTOBL
+48 SET DA=ACRLBDA
+49 SET DIE="^ACRLOCB("
+50 SET DR="2////"_ACRREQ_";7////"_ACROBL
+51 DO DIE^ACRFDIC
End DoDot:1
+52 KILL DIE,DA,DR
+53 NEW X
+54 SET X=^ACRDOC(ACRDOCDA,0)
+55 SET ACRDOCX=$PIECE(X,U)
+56 SET ACRREFDA=$PIECE(X,U,13)
+57 SET ACRTXDA=$PIECE(X,U,4)
+58 SET (ACRREF,ACRREFX)=$PIECE(^AUTTDOCR(ACRREFDA,0),U)
+59 IF ACRREF'=130
IF ACRREF'=600
Begin DoDot:1
+60 SET ACRREFX=$SELECT(ACRREF'=148:116,1:ACRREF)
+61 SET ACRREFDA=$ORDER(^AUTTDOCR("B",ACRREFX,0))
+62 DO DOC^ACRFDOCN
End DoDot:1
IF 1
+63 IF '$TEST
DO TO^ACRFDOCN
+64 SET DA=ACRDOCDA
+65 SET DIE="^ACRDOC("
+66 SET DR=".01///"_ACRDOC_";.17////"_ACRDOCX
+67 DO DIE^ACRFDIC
+68 IF '$DATA(ACRJVOD)
DO ^ACRFAPVS
+69 WRITE !!,@ACRON,ACRDOCX," (",ACRID,")",@ACROF," has been transferred to the"
+70 WRITE !,@ACRON,$PIECE(^ACRLOCB(ACRFDNO,0),U,12),@ACROF," account (ID NO.: ",ACRFDNO,")."
+71 WRITE !,"The new document number is ",@ACRON,ACRDOC,@ACROF," (ID NO.: ",ACRDOCDA,")."
+72 DO PAUSE^ACRFWARN
+73 SET ACRQUIT=""
+74 QUIT
JVOD ;EP;TO JOURNAL VOUCHER OBLIGATED DOCUMENT
+1 DO T
+2 QUIT
CANYO ;EP;TO CANCEL/DELETE YOUR OWN REQUEST
+1 SET DIC="^ACRDOC("
+2 SET DIC(0)="QEALM"
+3 SET DIC("A")="Requisition/Travel Order NO.: "
+4 SET D="B^C^G^J"
+5 SET DIC("S")="S ACRREFDA=$P(^ACRDOC(+Y,0),U,13),ACRREQ=$P(^(""REQ2""),U,8),ACRTO=$P($G(^(""TO"")),U,9),ACRAPV=$P($G(^ACROBL(+Y,""APV"")),U,8),ACRREF=$P(^AUTTDOCR(ACRREFDA,0),U),ACRYO=$S(""^116^204^103^210^""[(U_ACRREF_U):ACRREQ,1:ACRTO)"
+6 SET DIC("S")=DIC("S")_" I ACRYO=DUZ,ACRREF'=103,ACRAPV'=""A"""
+7 WRITE !,"Select the document you want to DELETE/CANCEL"
+8 WRITE !!
+9 DO MIX^ACRFDIC
+10 IF +Y<1
QUIT
+11 SET ACRDOCDA=+Y
+12 DO SETDOC^ACRFEA1
CANYO1 ;EP;AFTER DOCUMENT HAS BEEN SELECTED
+1 IF ACRREF=600
SET ACRCANCL=""
+2 DO EN2
+3 KILL ACRCANCL
+4 QUIT
CANPO QUIT
+1 SET DA=ACRDOCDA
+2 SET DIE="^ACRDOC("
+3 SET DR="1901T"
+4 WRITE !
+5 DO DIE^ACRFDIC
+6 SET ACRFDNO=ACRLBDA
+7 SET ACRCANDA=$PIECE(^ACRLOCB(ACRLBDA,"DT"),U)
+8 SET ACRAMEND=""
+9 DO EN1^ACRFAUTO
+10 QUIT
DHR ;
+1 NEW X,Y
+2 SET X=0
+3 FOR
SET X=$ORDER(^ACRDHR("E",ACRDOCDA,X))
IF 'X
QUIT
SET Y=$GET(^ACRDHR(X,1))
IF $PIECE(Y,U,3,4)="050^1"
SET ACRQUIT=""
QUIT
+4 IF '$DATA(ACRQUIT)
QUIT
+5 KILL ACRQUIT
+6 SET ACRTCODE="050"
+7 SET ACRRCODE=2
+8 SET ACRMCODE=$SELECT($GET(ACRMCODE):ACRMCODE,1:5)
+9 DO ^ACRFDHR
+10 KILL ACRTCODE,ACRRCODE,ACRMCODE
+11 QUIT
