ACRFDA.m

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