ACRFDA ;IHS/OIRM/DSD/THL,AEF - DISAPPROVAL HISTORY REPORT; [ 09/23/2005 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
EN ;EP;
F D EN1 Q:$D(ACRQUIT)!$D(ACROUT)
EXIT K ACRQUIT,ACROUT,ACR0,ACRAPDA,ACRCNG,ACRDAT,ACRPAI,ACRJ,ACRDOCDA,ACRI,ACRINAM,ACRINDV,ACRINDVA,ACRNO,ACRRESP,ACRRSN,ACRRTN,ACRAPDA,ACRY,ACRZ,ACRDT,ACRDATE,ACRX,ACRQUIT
K ^TMP("ACRDA",$J)
Q
EN1 D EXIT
D SELECT
Q:$D(ACRQUIT)!$D(ACROUT)
D PRINT
Q
SELECT ;SELECT DOCUMENT FOR DA HISTORY REPORT
S DIC="^ACRDOC("
S DIC(0)="AEMQZ"
S DIC("A")="Which Document: "
S DIC("S")="I $D(^ACRAPVS(""D"",+Y))"
W @IOF,!?20,"DELETED Signature History Report"
W !!,"The report which follows lists all DELETED approvals for the selected document."
W !,"The approvals listed may have been deleted because the document was DISAPPROVED"
W !,"or becuase accounting or item information was changed or because the document"
W !,"was re-sent for approval. ARMS does not know WHY these signatures were"
W !,"deleted but the listing below will indicate who deleted them and when.",!!
D DIC^ACRFDIC
I $G(Y)<1 S ACRQUIT="" Q
S ACRDOCDA=+Y
Q
PRINT ;PRINT REPORT
N X
S (ZTRTN,ACRRTN)="P1^ACRFDA"
S X=$P(^ACRDOC(ACRDOCDA,0),U,1,2)
S X=$P(X,U)_$S($P(X,U,2)]""&($P(X,U,2)'=$P(X,U)):" ("_$P(X,U,2)_")",1:"")
S ZTDESC="DELETED APPROVALS FOR "_X
D ^ACRFZIS
K ACRQUIT
Q
P1 ;EP;TO PRINT DA HISTORY REPORT
S (ACRAPDA,ACRJ)=0
F S ACRAPDA=$O(^ACRAPVS("D",ACRDOCDA,ACRAPDA)) Q:'ACRAPDA I $D(^ACRAPVS(ACRAPDA,0)) S Y=^(0) D
.S ACRDATE=$E($P(Y,U,10),1,13)
.S:'ACRDATE ACRDATE="NOT STATED"
.S ^TMP("ACRDA",$J,+$P(Y,U,6),ACRDATE,$P(Y,U,4),ACRAPDA)=""
Q:'$D(^TMP("ACRDA",$J))#2
S ACRREFDA=0
F S ACRREFDA=$O(^TMP("ACRDA",$J,ACRREFDA)) Q:'ACRREFDA D
.S ACRJ="",ACRI=0
.F S ACRJ=$O(^TMP("ACRDA",$J,ACRREFDA,ACRJ)) Q:ACRJ="" D
..S ACRPAI=0
..F S ACRPAI=$O(^TMP("ACRDA",$J,ACRREFDA,ACRJ,ACRPAI)) Q:'ACRPAI D
...S:ACRPAI=1 ACRI=ACRI+1
...S ACRAPDA=0
...F S ACRAPDA=$O(^TMP("ACRDA",$J,ACRREFDA,ACRJ,ACRPAI,ACRAPDA)) Q:'ACRAPDA D P
D S
D PAUSE^ACRFWARN
D EXIT:'$D(ACRSIGS)
Q
P S ACR0=^ACRAPVS(ACRAPDA,0)
S ACRDT=^ACRAPVS(ACRAPDA,"DT")
S ACRRSN=$G(^ACRAPVS(ACRAPDA,"RSN"))
S ACRCNG=$G(^ACRAPVS(ACRAPDA,"CNG"))
I ACRPAI=1 D
.I $G(ACRDAT),ACRDAT D
..D S
..D PAUSE^ACRFWARN
.S ACRDAT=$G(ACRDAT)+1
.N X,Y
.S X=$P(ACR0,U,9)
.S Y=$P(ACR0,U,10)
.W !,"The approvals listed below were deleted by: "
.;S X=$P($G(^VA(200,+X,0)),U) ;ACR*2.1*19.02 IM16848
.;S X=$P($P(X,",",2)," ")_" "_$P(X,",") ;ACR*2.1*19.02 IM18648
.S X=$$NAME3^ACRFUTL1(+X) ;ACR*2.1*19.02 IM16848
.W !,X
.D:Y]""
..X:Y ^DD("DD")
..W " on ",Y
.W !!
S D0=ACRAPDA
D ^ACRPRCA
I $D(ACRSIGS) S ACRSIGS(ACRDAT,ACRAPDA)=""
Q
SIGS ;EP;TO RECOUP DELETED SIGS
K ACRSIGS
S ACRSIGS=""
D EN1
I $D(^ACRAPVS("AB",ACRDOCDA)) D I $D(ACRQUIT) D OUT Q
.S DIR(0)="YO"
.S DIR("A",1)="There are active signatures on file for this document"
.S DIR("A")="Delete these signatures"
.S DIR("B")="NO"
.W !
.D DIR^ACRFDIC
.I +Y=1 K ^ACRAPVS("AB",ACRDOCDA) Q
.K ACRQUIT
.S DIR(0)="YO"
.S DIR("A",1)="You may end up with two sets of active signatures"
.S DIR("A")="Are you certain this is what you want"
.S DIR("B")="NO"
.W !
.D DIR^ACRFDIC
.Q:+Y=1
.K ^ACRAPVS("AB",ACRDOCDA)
S DIR(0)="NO^1:"_ACRDAT
S DIR("A")="Which set should be restored"
W !!
D DIR^ACRFDIC
Q:'+$G(Y)
S ACRX=+Y
N X
S X=0
F S X=$O(ACRSIGS(ACRX,X)) Q:'X D
.W !,ACRDOCDA,?10,X
.S ^ACRAPVS("AB",ACRDOCDA,X)=""
.K ^ACRAPVS("D",ACRDOCDA,X)
.S ^ACRAPVS("AORDR",ACRDOCDA,+$P($G(^ACRAPVS(X,0)),U,4),X)=""
OUT D EXIT
K ACRSIGS
Q
S ;DISPLAY APPROVAL IEN'S
Q:'$O(ACRSIGS(0))
W !!,"ID NO's: Set number ",ACRDAT,!
N X
S X=0
F S X=$O(ACRSIGS(ACRDAT,X)) Q:'X W X,", "
Q
ACRFDA ;IHS/OIRM/DSD/THL,AEF - DISAPPROVAL HISTORY REPORT; [ 09/23/2005 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
EN ;EP;
+1 FOR
DO EN1
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
EXIT KILL ACRQUIT,ACROUT,ACR0,ACRAPDA,ACRCNG,ACRDAT,ACRPAI,ACRJ,ACRDOCDA,ACRI,ACRINAM,ACRINDV,ACRINDVA,ACRNO,ACRRESP,ACRRSN,ACRRTN,ACRAPDA,ACRY,ACRZ,ACRDT,ACRDATE,ACRX,ACRQUIT
+1 KILL ^TMP("ACRDA",$JOB)
+2 QUIT
EN1 DO EXIT
+1 DO SELECT
+2 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+3 DO PRINT
+4 QUIT
SELECT ;SELECT DOCUMENT FOR DA HISTORY REPORT
+1 SET DIC="^ACRDOC("
+2 SET DIC(0)="AEMQZ"
+3 SET DIC("A")="Which Document: "
+4 SET DIC("S")="I $D(^ACRAPVS(""D"",+Y))"
+5 WRITE @IOF,!?20,"DELETED Signature History Report"
+6 WRITE !!,"The report which follows lists all DELETED approvals for the selected document."
+7 WRITE !,"The approvals listed may have been deleted because the document was DISAPPROVED"
+8 WRITE !,"or becuase accounting or item information was changed or because the document"
+9 WRITE !,"was re-sent for approval. ARMS does not know WHY these signatures were"
+10 WRITE !,"deleted but the listing below will indicate who deleted them and when.",!!
+11 DO DIC^ACRFDIC
+12 IF $GET(Y)<1
SET ACRQUIT=""
QUIT
+13 SET ACRDOCDA=+Y
+14 QUIT
PRINT ;PRINT REPORT
+1 NEW X
+2 SET (ZTRTN,ACRRTN)="P1^ACRFDA"
+3 SET X=$PIECE(^ACRDOC(ACRDOCDA,0),U,1,2)
+4 SET X=$PIECE(X,U)_$SELECT($PIECE(X,U,2)]""&($PIECE(X,U,2)'=$PIECE(X,U)):" ("_$PIECE(X,U,2)_")",1:"")
+5 SET ZTDESC="DELETED APPROVALS FOR "_X
+6 DO ^ACRFZIS
+7 KILL ACRQUIT
+8 QUIT
P1 ;EP;TO PRINT DA HISTORY REPORT
+1 SET (ACRAPDA,ACRJ)=0
+2 FOR
SET ACRAPDA=$ORDER(^ACRAPVS("D",ACRDOCDA,ACRAPDA))
IF 'ACRAPDA
QUIT
IF $DATA(^ACRAPVS(ACRAPDA,0))
SET Y=^(0)
Begin DoDot:1
+3 SET ACRDATE=$EXTRACT($PIECE(Y,U,10),1,13)
+4 IF 'ACRDATE
SET ACRDATE="NOT STATED"
+5 SET ^TMP("ACRDA",$JOB,+$PIECE(Y,U,6),ACRDATE,$PIECE(Y,U,4),ACRAPDA)=""
End DoDot:1
+6 IF '$DATA(^TMP("ACRDA",$JOB))#2
QUIT
+7 SET ACRREFDA=0
+8 FOR
SET ACRREFDA=$ORDER(^TMP("ACRDA",$JOB,ACRREFDA))
IF 'ACRREFDA
QUIT
Begin DoDot:1
+9 SET ACRJ=""
SET ACRI=0
+10 FOR
SET ACRJ=$ORDER(^TMP("ACRDA",$JOB,ACRREFDA,ACRJ))
IF ACRJ=""
QUIT
Begin DoDot:2
+11 SET ACRPAI=0
+12 FOR
SET ACRPAI=$ORDER(^TMP("ACRDA",$JOB,ACRREFDA,ACRJ,ACRPAI))
IF 'ACRPAI
QUIT
Begin DoDot:3
+13 IF ACRPAI=1
SET ACRI=ACRI+1
+14 SET ACRAPDA=0
+15 FOR
SET ACRAPDA=$ORDER(^TMP("ACRDA",$JOB,ACRREFDA,ACRJ,ACRPAI,ACRAPDA))
IF 'ACRAPDA
QUIT
DO P
End DoDot:3
End DoDot:2
End DoDot:1
+16 DO S
+17 DO PAUSE^ACRFWARN
+18 IF '$DATA(ACRSIGS)
DO EXIT
+19 QUIT
P SET ACR0=^ACRAPVS(ACRAPDA,0)
+1 SET ACRDT=^ACRAPVS(ACRAPDA,"DT")
+2 SET ACRRSN=$GET(^ACRAPVS(ACRAPDA,"RSN"))
+3 SET ACRCNG=$GET(^ACRAPVS(ACRAPDA,"CNG"))
+4 IF ACRPAI=1
Begin DoDot:1
+5 IF $GET(ACRDAT)
IF ACRDAT
Begin DoDot:2
+6 DO S
+7 DO PAUSE^ACRFWARN
End DoDot:2
+8 SET ACRDAT=$GET(ACRDAT)+1
+9 NEW X,Y
+10 SET X=$PIECE(ACR0,U,9)
+11 SET Y=$PIECE(ACR0,U,10)
+12 WRITE !,"The approvals listed below were deleted by: "
+13 ;S X=$P($G(^VA(200,+X,0)),U) ;ACR*2.1*19.02 IM16848
+14 ;S X=$P">P">P">P($P">P">P">P(X,",",2)," ")_" "_$P">P">P">P(X,",") ;ACR*2.1*19.02 IM18648
+15 ;ACR*2.1*19.02 IM16848
SET X=$$NAME3^ACRFUTL1(+X)
+16 WRITE !,X
+17 IF Y]""
Begin DoDot:2
+18 IF Y
XECUTE ^DD("DD")
+19 WRITE " on ",Y
End DoDot:2
+20 WRITE !!
End DoDot:1
+21 SET D0=ACRAPDA
+22 DO ^ACRPRCA
+23 IF $DATA(ACRSIGS)
SET ACRSIGS(ACRDAT,ACRAPDA)=""
+24 QUIT
SIGS ;EP;TO RECOUP DELETED SIGS
+1 KILL ACRSIGS
+2 SET ACRSIGS=""
+3 DO EN1
+4 IF $DATA(^ACRAPVS("AB",ACRDOCDA))
Begin DoDot:1
+5 SET DIR(0)="YO"
+6 SET DIR("A",1)="There are active signatures on file for this document"
+7 SET DIR("A")="Delete these signatures"
+8 SET DIR("B")="NO"
+9 WRITE !
+10 DO DIR^ACRFDIC
+11 IF +Y=1
KILL ^ACRAPVS("AB",ACRDOCDA)
QUIT
+12 KILL ACRQUIT
+13 SET DIR(0)="YO"
+14 SET DIR("A",1)="You may end up with two sets of active signatures"
+15 SET DIR("A")="Are you certain this is what you want"
+16 SET DIR("B")="NO"
+17 WRITE !
+18 DO DIR^ACRFDIC
+19 IF +Y=1
QUIT
+20 KILL ^ACRAPVS("AB",ACRDOCDA)
End DoDot:1
IF $DATA(ACRQUIT)
DO OUT
QUIT
+21 SET DIR(0)="NO^1:"_ACRDAT
+22 SET DIR("A")="Which set should be restored"
+23 WRITE !!
+24 DO DIR^ACRFDIC
+25 IF '+$GET(Y)
QUIT
+26 SET ACRX=+Y
+27 NEW X
+28 SET X=0
+29 FOR
SET X=$ORDER(ACRSIGS(ACRX,X))
IF 'X
QUIT
Begin DoDot:1
+30 WRITE !,ACRDOCDA,?10,X
+31 SET ^ACRAPVS("AB",ACRDOCDA,X)=""
+32 KILL ^ACRAPVS("D",ACRDOCDA,X)
+33 SET ^ACRAPVS("AORDR",ACRDOCDA,+$PIECE($GET(^ACRAPVS(X,0)),U,4),X)=""
End DoDot:1
OUT DO EXIT
+1 KILL ACRSIGS
+2 QUIT
S ;DISPLAY APPROVAL IEN'S
+1 IF '$ORDER(ACRSIGS(0))
QUIT
+2 WRITE !!,"ID NO's: Set number ",ACRDAT,!
+3 NEW X
+4 SET X=0
+5 FOR
SET X=$ORDER(ACRSIGS(ACRDAT,X))
IF 'X
QUIT
WRITE X,", "
+6 QUIT
