ACRFPSR.m

ACRFPSR ;IHS/OIRM/DSD/THL,AEF - PENDING SIGNATURE REPORT; [ 09/23/2005   9:44 AM ]

 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001

 ;;ROUTINE TO PRINT PENDING SIGNATURE REPORT

 D EXIT,CHOICE,EXIT

 Q

EN ;EP;TO PRINT LIST OF ALL DOCUMENTS WHICH NEED TO BE SIGNED

 D EN1

EXIT K ^TMP("ACRPSR",$J),^TMP("ACRINDV",$J),ACRTIME,ACRDOCDA,ACR0,ACRDT,ACRPO,ACRIN,ACRINDV,ACRAPDA,ACRDUZ,ACRAPVT,ACRLBDA,ACRDOC,ACRLB,ACRPODA,ACRPRTR,ACRX,ACRTODAY,ACRAPV,ACRINDVZ,ACRDEPTZ,ACRPOZ,ACRQUIT,ACROUT,ACRALLZ

 Q

EN1 ;EP;CHECK ALL DOCUMENTS PENDING A SIGNATURE

 S Y=DT

 X ^DD("DD")

 S ACRTODAY=Y

 S X=DT

 D DW^%DTC

 Q:"SATSUN"[$E(X,1,3)

 S ACRAPVT=0

 F  S ACRAPVT=$O(^ACRAPVS("ANXT",ACRAPVT)) Q:'ACRAPVT!$D(ACRQUIT)  D

 .S ACRDUZ=0

 .F  S ACRDUZ=$O(^ACRAPVS("ANXT",ACRAPVT,ACRDUZ)) Q:'ACRDUZ!$D(ACRQUIT)  D

 ..S ACRAPDA=0

 ..F  S ACRAPDA=$O(^ACRAPVS("ANXT",ACRAPVT,ACRDUZ,ACRAPDA)) Q:'ACRAPDA!$D(ACRQUIT)  I $D(^ACRAPVS(ACRAPDA,0)),$D(^ACRAPVS(ACRAPDA,"DT")) D EN2

 D:$D(^TMP("ACRPSR",$J))&'$D(ACRINDVZ) EN3

 I $D(^TMP("ACRINDV",$J)),$D(ACRALLZ)!$D(ACRINDVZ) D

 .D EN4

 .I '$D(ACRINDVZ) S ACRALL="" D EN4 K ACRALL

 D EXIT

 Q

EN2 S ACR0=^ACRAPVS(ACRAPDA,0)

 S ACRDT=^ACRAPVS(ACRAPDA,"DT")

 I $P(ACR0,U,3)'=ACRAPVT!($P(ACRDT,U,2)'=ACRDUZ) K ^ACRAPVS("ANXT",ACRAPVT,ACRDUZ,ACRAPDA) Q

 S ACRDOCDA=+ACR0

 S ACRLBDA=$P(ACR0,U,5)

 Q:$P(ACRDT,U,8)>DT

 I $D(ACRDEPTZ),$P(^ACRLOCB(ACRLBDA,0),U,5)'=ACRDEPTZ Q

 N X

 S X=^ACRDOC(ACRDOCDA,0)

 S ACRPO=$P(X,U,8)

 S ACRDOC=$P(X,U)

 S:$P(X,U)'=$P(X,U,2) ACRDOC=ACRDOC_"  "_$P(X,U,2)

 S ACRID=$P(X,U,14)

 S ACRTIME=$P(^ACRPO(ACRPO,0),U,6)

 S ACRPRTR=$P(^ACRPO(ACRPO,0),U,2)

 S ACRIN=$P(ACRDT,U,3)

 S ACRAPV=$P(^ACRAPVT(ACRAPVT,0),U)

 S X1=DT

 S X2=ACRIN

 D ^%DTC

 Q:X<ACRTIME

 S Y=ACRIN

 X ^DD("DD")

 S ACRIN=Y

 ;I $D(ACRINDVZ),ACRINDVZ S ACRINDV=$E($P(^VA(200,ACRINDVZ,0),U),1,20)  ;ACR*2.1*19.02 IM16848

 ;E  S ACRINDV=$E($P(^VA(200,ACRDUZ,0),U),1,20)  ;ACR*2.1*19.02 IM16848

 I $D(ACRINDVZ),ACRINDVZ S ACRINDV=$E($$NAME2^ACRFUTL1(ACRINDVZ),1,20)  ;ACR*2.1*19.02 IM16848

 E  S ACRINDV=$E($$NAME2^ACRFUTL1(ACRDUZ),1,20)  ;ACR*2.1*19.02 IM16848

 S:'$D(ACRINDVZ) ACRIN=Y,^TMP("ACRPSR",$J,ACRPO,ACRLBDA,ACRINDV,ACRDOC)=ACRIN_U_ACRAPV_U_ACRID

 S:$D(ACRALLZ)!($G(ACRINDVZ)=ACRDUZ) ^TMP("ACRINDV",$J,ACRPO,ACRINDV,ACRDOC)=ACRIN_U_ACRAPV_U_ACRID

 Q

EN3 ;PRINT LIST OF DOCUMENTS PENDING GREATER THAN SPECIFIED # OF DAYS BY

 ;DEPARTMENT ACCOUNT

 S ACRPODA=$S($D(ACRPOZ):ACRPOZ-1,1:0),ACRX=1

 F  S ACRPODA=$O(^TMP("ACRPSR",$J,ACRPODA)) Q:$D(ACRQUIT)!'ACRPODA!($G(ACRPOZ)&(ACRPODA<$G(ACRPOZ)))  I $D(^ACRPO(ACRPODA,0)) S ACRPRTR=$P(^(0),U,2),ACRPO=$P(^AUTTLOC(+^(0),0),U,2),ACRLBDA=0 D

 .Q:'ACRPRTR

 .I $D(ACRALLZ) S IOP=$P(^%ZIS(1,ACRPRTR,0),U),%ZIS="P" D ^%ZIS Q:POP

 .F  S ACRLBDA=$O(^TMP("ACRPSR",$J,ACRPODA,ACRLBDA)) Q:'ACRLBDA!$D(ACRQUIT)  I $D(^ACRLOCB(ACRLBDA,0)),$P(^(0),U,5) S ACRLB=$P(^AUTTPRG($P(^(0),U,5),0),U) D

 ..U IO

 ..D HEAD^ACRFPSR1

 ..S ACRINDV=""

 ..F  S ACRINDV=$O(^TMP("ACRPSR",$J,ACRPODA,ACRLBDA,ACRINDV)) Q:$D(ACRQUIT)!(ACRINDV="")!($D(ACRINDVZ)&(ACRINDV>$G(ACRINDVZ)))  D

 ...S ACRDOC=""

 ...F  S ACRDOC=$O(^TMP("ACRPSR",$J,ACRPODA,ACRLBDA,ACRINDV,ACRDOC)) Q:ACRDOC=""!$D(ACRQUIT)  N X S X=^(ACRDOC) D

 ....S ACRIN=$P(X,U),ACRAPV=$P(X,U,2),ACRID=$P(X,U,3)

 ....D W

 ..D PAUSE^ACRFWARN

 .D ^%ZISC

 Q

EN4 ;PRINT LIST OF DOCUMENTS PENDING GREATER THAN SPECIFIED # OF DAYS BY

 ;INDIVIDUAL

 S ACRPODA=$S($D(ACRPOZ):ACRPOZ,1:0),ACRX=2

 F  S ACRPODA=$O(^TMP("ACRINDV",$J,ACRPODA)) Q:'ACRPODA!$D(ACRQUIT)!($G(ACRPOZ)&(ACRPODA<$G(ACRPOZ)))  I $D(^ACRPO(ACRPODA,0)) D

 .S ACRPRTR=$P(^ACRPO(ACRPODA,0),U,2)

 .S ACRPO=$P(^AUTTLOC(+^(0),0),U,2)

 .S ACRLBDA=0

 .S ACRINDV=""

 .I $D(ACRALLZ) S IOP=$P(^%ZIS(1,ACRPRTR,0),U),%ZIS="P" D ^%ZIS Q:POP

 .U IO

 .D HEAD^ACRFPSR1:$D(ACRALL)

 .I $D(ACRINDVZ)

 .F  S ACRINDV=$O(^TMP("ACRINDV",$J,ACRPODA,ACRINDV)) Q:ACRINDV=""!$D(ACRQUIT)  D

 ..D:'$D(ACRALL) HEAD^ACRFPSR1

 ..N X

 ..S ACRDOC=""

 ..F  S ACRDOC=$O(^TMP("ACRINDV",$J,ACRPODA,ACRINDV,ACRDOC)) Q:ACRDOC=""!$D(ACRQUIT)  S X=^(ACRDOC) D

 ...S ACRIN=$P(X,U)

 ...S ACRAPV=$P(X,U,2)

 ...S ACRID=$P(X,U,3)

 ...D W

 .W:$D(ACRALL) @IOF

 .D ^%ZISC

 Q

W ;DISPLAY NAME, DOCUMENT NUMBER AND TIME RECEIVED FOR SIGNATURE

 W !?5,ACRINDV

 W ?27,ACRDOC

 W ?56,ACRID

 W !?27,ACRAPV

 W ?56,ACRIN

 I $D(IOSL),$Y>(IOSL-4) D

 .D PAUSE^ACRFWARN

 .D HEAD^ACRFPSR1

 Q

CHOICE ;EP;TO SELECT TYPE OF REPORT

 S DIR(0)="SO^1:All Reports;2:Purchasing Office;3:Selected Department;4:Individual ARMS User"

 S DIR("A")="Which Report"

 S DIR("B")="All Reports"

 W !

 D DIR^ACRFDIC

 Q:$D(ACRQUIT)!$D(ACROUT)!'+ACRY

 I ACRY=1 D  Q

 .S ACRALLZ=""

 .S ZTRTN="EN1^ACRFPSR"

 .S ION=""

 .D ZIS

 .D ZTLOAD^ACRFZIS

 I ACRY=2 D PO S ACRY=2

 I ACRY=3 D DEPT S ACRY=3

 I ACRY=4 D INDV S ACRY=4

 D ZIS

 Q

PO ;EP;

 S DIC="^ACRPO("

 S DIC(0)="AEMQZ"

 S DIC("A")="Which Purchasing Office: "

 W !

 D DIC^ACRFDIC

 Q:$D(ACRQUIT)!$D(ACROUT)!'+$G(Y)

 I +Y<0 S ACRQUIT="" Q

 S ACRPOZ=+Y

 Q

DEPT ;

 S DIC="^AUTTPRG("

 S DIC(0)="AEMQZ"

 S DIC("A")="Which Department.......: "

 W !

 D DIC^ACRFDIC

 Q:$D(ACRQUIT)!$D(ACROUT)!'+$G(Y)

 I +Y<0 S ACRQUIT="" Q

 S ACRDEPTZ=+Y

 Q

INDV ;

 S DIC="^ACRAU("

 S DIC(0)="AEMQZ"

 S DIC("A")="Which ARMS User........: "

 W !

 D DIC^ACRFDIC

 Q:$D(ACRQUIT)!$D(ACROUT)!'+$G(Y)

 I +Y<0 S ACRQUIT="" Q

 S ACRINDVZ=+Y

 Q

ZIS ;EP;TO SELECT SPECIFIC PRINTER

 S ACRRTN="EN1^ACRFPSR"

 S ZTDESC="PRINT UNSIGNED DOCUMENT REPORT"

 D ^ACRFZIS:'$D(ACRALLZ)

 Q

ACRFPSR   ;IHS/OIRM/DSD/THL,AEF - PENDING SIGNATURE REPORT; [ 09/23/2005   9:44 AM ]

 +1       ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001

 +2       ;;ROUTINE TO PRINT PENDING SIGNATURE REPORT

 +3        DO EXIT

           DO CHOICE

           DO EXIT

 +4        QUIT 

EN        ;EP;TO PRINT LIST OF ALL DOCUMENTS WHICH NEED TO BE SIGNED

 +1        DO EN1

EXIT       KILL ^TMP("ACRPSR",$JOB),^TMP("ACRINDV",$JOB),ACRTIME,ACRDOCDA,ACR0,ACRDT,ACRPO,ACRIN,ACRINDV,ACRAPDA,ACRDUZ,ACRAPVT,ACRLBDA,ACRDOC,ACRLB,ACRPODA,ACRPRTR,ACRX,ACRTODAY,ACRAPV,ACRINDVZ,ACRDEPTZ,ACRPOZ,ACRQUIT,ACROUT,ACRALLZ

 +1        QUIT 

EN1       ;EP;CHECK ALL DOCUMENTS PENDING A SIGNATURE

 +1        SET Y=DT

 +2        XECUTE ^DD("DD")

 +3        SET ACRTODAY=Y

 +4        SET X=DT

 +5        DO DW^%DTC

 +6        IF "SATSUN"[$EXTRACT(X,1,3)

               QUIT 

 +7        SET ACRAPVT=0

 +8        FOR 

               SET ACRAPVT=$ORDER(^ACRAPVS("ANXT",ACRAPVT))

               IF 'ACRAPVT!$DATA(ACRQUIT)

                   QUIT 

               Begin DoDot:1

 +9                SET ACRDUZ=0

 +10               FOR 

                       SET ACRDUZ=$ORDER(^ACRAPVS("ANXT",ACRAPVT,ACRDUZ))

                       IF 'ACRDUZ!$DATA(ACRQUIT)

                           QUIT 

                       Begin DoDot:2

 +11                       SET ACRAPDA=0

 +12                       FOR 

                               SET ACRAPDA=$ORDER(^ACRAPVS("ANXT",ACRAPVT,ACRDUZ,ACRAPDA))

                               IF 'ACRAPDA!$DATA(ACRQUIT)

                                   QUIT 

                               IF $DATA(^ACRAPVS(ACRAPDA,0))

                                   IF $DATA(^ACRAPVS(ACRAPDA,"DT"))

                                       DO EN2

                       End DoDot:2

               End DoDot:1

 +13       IF $DATA(^TMP("ACRPSR",$JOB))&'$DATA(ACRINDVZ)

               DO EN3

 +14       IF $DATA(^TMP("ACRINDV",$JOB))

               IF $DATA(ACRALLZ)!$DATA(ACRINDVZ)

                   Begin DoDot:1

 +15                   DO EN4

 +16                   IF '$DATA(ACRINDVZ)

                           SET ACRALL=""

                           DO EN4

                           KILL ACRALL

                   End DoDot:1

 +17       DO EXIT

 +18       QUIT 

EN2        SET ACR0=^ACRAPVS(ACRAPDA,0)

 +1        SET ACRDT=^ACRAPVS(ACRAPDA,"DT")

 +2        IF $PIECE(ACR0,U,3)'=ACRAPVT!($PIECE(ACRDT,U,2)'=ACRDUZ)

               KILL ^ACRAPVS("ANXT",ACRAPVT,ACRDUZ,ACRAPDA)

               QUIT 

 +3        SET ACRDOCDA=+ACR0

 +4        SET ACRLBDA=$PIECE(ACR0,U,5)

 +5        IF $PIECE(ACRDT,U,8)>DT

               QUIT 

 +6        IF $DATA(ACRDEPTZ)

               IF $PIECE(^ACRLOCB(ACRLBDA,0),U,5)'=ACRDEPTZ

                   QUIT 

 +7        NEW X

 +8        SET X=^ACRDOC(ACRDOCDA,0)

 +9        SET ACRPO=$PIECE(X,U,8)

 +10       SET ACRDOC=$PIECE(X,U)

 +11       IF $PIECE(X,U)'=$PIECE(X,U,2)

               SET ACRDOC=ACRDOC_"  "_$PIECE(X,U,2)

 +12       SET ACRID=$PIECE(X,U,14)

 +13       SET ACRTIME=$PIECE(^ACRPO(ACRPO,0),U,6)

 +14       SET ACRPRTR=$PIECE(^ACRPO(ACRPO,0),U,2)

 +15       SET ACRIN=$PIECE(ACRDT,U,3)

 +16       SET ACRAPV=$PIECE(^ACRAPVT(ACRAPVT,0),U)

 +17       SET X1=DT

 +18       SET X2=ACRIN

 +19       DO ^%DTC

 +20       IF X<ACRTIME

               QUIT 

 +21       SET Y=ACRIN

 +22       XECUTE ^DD("DD")

 +23       SET ACRIN=Y

 +24      ;I $D(ACRINDVZ),ACRINDVZ S ACRINDV=$E($P(^VA(200,ACRINDVZ,0),U),1,20)  ;ACR*2.1*19.02 IM16848

 +25      ;E  S ACRINDV=$E($P(^VA(200,ACRDUZ,0),U),1,20)  ;ACR*2.1*19.02 IM16848

 +26      ;ACR*2.1*19.02 IM16848

           IF $DATA(ACRINDVZ)

               IF ACRINDVZ

                   SET ACRINDV=$EXTRACT($$NAME2^ACRFUTL1(ACRINDVZ),1,20)

 +27      ;ACR*2.1*19.02 IM16848

          IF '$TEST

               SET ACRINDV=$EXTRACT($$NAME2^ACRFUTL1(ACRDUZ),1,20)

 +28       IF '$DATA(ACRINDVZ)

               SET ACRIN=Y

               SET ^TMP("ACRPSR",$JOB,ACRPO,ACRLBDA,ACRINDV,ACRDOC)=ACRIN_U_ACRAPV_U_ACRID

 +29       IF $DATA(ACRALLZ)!($GET(ACRINDVZ)=ACRDUZ)

               SET ^TMP("ACRINDV",$JOB,ACRPO,ACRINDV,ACRDOC)=ACRIN_U_ACRAPV_U_ACRID

 +30       QUIT 

EN3       ;PRINT LIST OF DOCUMENTS PENDING GREATER THAN SPECIFIED # OF DAYS BY

 +1       ;DEPARTMENT ACCOUNT

 +2        SET ACRPODA=$SELECT($DATA(ACRPOZ):ACRPOZ-1,1:0)

           SET ACRX=1

 +3        FOR 

               SET ACRPODA=$ORDER(^TMP("ACRPSR",$JOB,ACRPODA))

               IF $DATA(ACRQUIT)!'ACRPODA!($GET(ACRPOZ)&(ACRPODA<$GET(ACRPOZ)))

                   QUIT 

               IF $DATA(^ACRPO(ACRPODA,0))

                   SET ACRPRTR=$PIECE(^(0),U,2)

                   SET ACRPO=$PIECE(^AUTTLOC(+^(0),0),U,2)

                   SET ACRLBDA=0

                   Begin DoDot:1

 +4                    IF 'ACRPRTR

                           QUIT 

 +5                    IF $DATA(ACRALLZ)

                           SET IOP=$PIECE(^%ZIS(1,ACRPRTR,0),U)

                           SET %ZIS="P"

                           DO ^%ZIS

                           IF POP

                               QUIT 

 +6                    FOR 

                           SET ACRLBDA=$ORDER(^TMP("ACRPSR",$JOB,ACRPODA,ACRLBDA))

                           IF 'ACRLBDA!$DATA(ACRQUIT)

                               QUIT 

                           IF $DATA(^ACRLOCB(ACRLBDA,0))

                               IF $PIECE(^(0),U,5)

                                   SET ACRLB=$PIECE(^AUTTPRG($PIECE(^(0),U,5),0),U)

                                   Begin DoDot:2

 +7                                    USE IO

 +8                                    DO HEAD^ACRFPSR1

 +9                                    SET ACRINDV=""

 +10                                   FOR 

                                           SET ACRINDV=$ORDER(^TMP("ACRPSR",$JOB,ACRPODA,ACRLBDA,ACRINDV))

                                           IF $DATA(ACRQUIT)!(ACRINDV="")!($DATA(ACRINDVZ)&(ACRINDV>$GET(ACRINDVZ)))

                                               QUIT 

                                           Begin DoDot:3

 +11                                           SET ACRDOC=""

 +12                                           FOR 

                                                   SET ACRDOC=$ORDER(^TMP("ACRPSR",$JOB,ACRPODA,ACRLBDA,ACRINDV,ACRDOC))

                                                   IF ACRDOC=""!$DATA(ACRQUIT)

                                                       QUIT 

                                                   NEW X

                                                   SET X=^(ACRDOC)

                                                   Begin DoDot:4

 +13                                                   SET ACRIN=$PIECE(X,U)

                                                       SET ACRAPV=$PIECE(X,U,2)

                                                       SET ACRID=$PIECE(X,U,3)

 +14                                                   DO W

                                                   End DoDot:4

                                           End DoDot:3

 +15                                   DO PAUSE^ACRFWARN

                                   End DoDot:2

 +16                   DO ^%ZISC

                   End DoDot:1

 +17       QUIT 

EN4       ;PRINT LIST OF DOCUMENTS PENDING GREATER THAN SPECIFIED # OF DAYS BY

 +1       ;INDIVIDUAL

 +2        SET ACRPODA=$SELECT($DATA(ACRPOZ):ACRPOZ,1:0)

           SET ACRX=2

 +3        FOR 

               SET ACRPODA=$ORDER(^TMP("ACRINDV",$JOB,ACRPODA))

               IF 'ACRPODA!$DATA(ACRQUIT)!($GET(ACRPOZ)&(ACRPODA<$GET(ACRPOZ)))

                   QUIT 

               IF $DATA(^ACRPO(ACRPODA,0))

                   Begin DoDot:1

 +4                    SET ACRPRTR=$PIECE(^ACRPO(ACRPODA,0),U,2)

 +5                    SET ACRPO=$PIECE(^AUTTLOC(+^(0),0),U,2)

 +6                    SET ACRLBDA=0

 +7                    SET ACRINDV=""

 +8                    IF $DATA(ACRALLZ)

                           SET IOP=$PIECE(^%ZIS(1,ACRPRTR,0),U)

                           SET %ZIS="P"

                           DO ^%ZIS

                           IF POP

                               QUIT 

 +9                    USE IO

 +10                   IF $DATA(ACRALL)

                           DO HEAD^ACRFPSR1

 +11                   IF $DATA(ACRINDVZ)

 +12                   FOR 

                           SET ACRINDV=$ORDER(^TMP("ACRINDV",$JOB,ACRPODA,ACRINDV))

                           IF ACRINDV=""!$DATA(ACRQUIT)

                               QUIT 

                           Begin DoDot:2

 +13                           IF '$DATA(ACRALL)

                                   DO HEAD^ACRFPSR1

 +14                           NEW X

 +15                           SET ACRDOC=""

 +16                           FOR 

                                   SET ACRDOC=$ORDER(^TMP("ACRINDV",$JOB,ACRPODA,ACRINDV,ACRDOC))

                                   IF ACRDOC=""!$DATA(ACRQUIT)

                                       QUIT 

                                   SET X=^(ACRDOC)

                                   Begin DoDot:3

 +17                                   SET ACRIN=$PIECE(X,U)

 +18                                   SET ACRAPV=$PIECE(X,U,2)

 +19                                   SET ACRID=$PIECE(X,U,3)

 +20                                   DO W

                                   End DoDot:3

                           End DoDot:2

 +21                   IF $DATA(ACRALL)

                           WRITE @IOF

 +22                   DO ^%ZISC

                   End DoDot:1

 +23       QUIT 

W         ;DISPLAY NAME, DOCUMENT NUMBER AND TIME RECEIVED FOR SIGNATURE

 +1        WRITE !?5,ACRINDV

 +2        WRITE ?27,ACRDOC

 +3        WRITE ?56,ACRID

 +4        WRITE !?27,ACRAPV

 +5        WRITE ?56,ACRIN

 +6        IF $DATA(IOSL)

               IF $Y>(IOSL-4)

                   Begin DoDot:1

 +7                    DO PAUSE^ACRFWARN

 +8                    DO HEAD^ACRFPSR1

                   End DoDot:1

 +9        QUIT 

CHOICE    ;EP;TO SELECT TYPE OF REPORT

 +1        SET DIR(0)="SO^1:All Reports;2:Purchasing Office;3:Selected Department;4:Individual ARMS User"

 +2        SET DIR("A")="Which Report"

 +3        SET DIR("B")="All Reports"

 +4        WRITE !

 +5        DO DIR^ACRFDIC

 +6        IF $DATA(ACRQUIT)!$DATA(ACROUT)!'+ACRY

               QUIT 

 +7        IF ACRY=1

               Begin DoDot:1

 +8                SET ACRALLZ=""

 +9                SET ZTRTN="EN1^ACRFPSR"

 +10               SET ION=""

 +11               DO ZIS

 +12               DO ZTLOAD^ACRFZIS

               End DoDot:1

               QUIT 

 +13       IF ACRY=2

               DO PO

               SET ACRY=2

 +14       IF ACRY=3

               DO DEPT

               SET ACRY=3

 +15       IF ACRY=4

               DO INDV

               SET ACRY=4

 +16       DO ZIS

 +17       QUIT 

PO        ;EP;

 +1        SET DIC="^ACRPO("

 +2        SET DIC(0)="AEMQZ"

 +3        SET DIC("A")="Which Purchasing Office: "

 +4        WRITE !

 +5        DO DIC^ACRFDIC

 +6        IF $DATA(ACRQUIT)!$DATA(ACROUT)!'+$GET(Y)

               QUIT 

 +7        IF +Y<0

               SET ACRQUIT=""

               QUIT 

 +8        SET ACRPOZ=+Y

 +9        QUIT 

DEPT      ;

 +1        SET DIC="^AUTTPRG("

 +2        SET DIC(0)="AEMQZ"

 +3        SET DIC("A")="Which Department.......: "

 +4        WRITE !

 +5        DO DIC^ACRFDIC

 +6        IF $DATA(ACRQUIT)!$DATA(ACROUT)!'+$GET(Y)

               QUIT 

 +7        IF +Y<0

               SET ACRQUIT=""

               QUIT 

 +8        SET ACRDEPTZ=+Y

 +9        QUIT 

INDV      ;

 +1        SET DIC="^ACRAU("

 +2        SET DIC(0)="AEMQZ"

 +3        SET DIC("A")="Which ARMS User........: "

 +4        WRITE !

 +5        DO DIC^ACRFDIC

 +6        IF $DATA(ACRQUIT)!$DATA(ACROUT)!'+$GET(Y)

               QUIT 

 +7        IF +Y<0

               SET ACRQUIT=""

               QUIT 

 +8        SET ACRINDVZ=+Y

 +9        QUIT 

ZIS       ;EP;TO SELECT SPECIFIC PRINTER

 +1        SET ACRRTN="EN1^ACRFPSR"

 +2        SET ZTDESC="PRINT UNSIGNED DOCUMENT REPORT"

 +3        IF '$DATA(ACRALLZ)

               DO ^ACRFZIS

 +4        QUIT