ACRFRRPT ;IHS/OIRM/DSD/THL,AEF - RECEIVING REPORT; [ 11/7/2006 12:48 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**16,19,22**;NOV 05, 2001
;;ROUTINE TO PRINT THE RECEIVING REPORT
EN K ^TMP("ACRRR",$J)
I $D(ACRRR)#2 D
.S ACRRRX=ACRRR
.K ACRRR
.S ACRRR=ACRRRX
.K ACRRRX
D EN3
D PRINT^ACRFPSS
D EN1
EXIT K ACRRRDA,ACRQUIT,ACRDOCDX,ACRSNUM,^TMP("ACRRR",$J)
Q
EN1 D HEAD^ACRFRRP1
N Z,ACRRRDA
S Z=0
S (ACRDATE,ACRDATE2)=""
F S Z=$O(^TMP("ACRRR",$J,Z)) Q:'Z!$D(ACRQUIT) D
.S ACRRRDA=^TMP("ACRRR",$J,Z)
.Q:'ACRRRDA
.Q:'$D(^ACRRR(ACRRRDA,0))!'$D(^ACRRR(ACRRRDA,"DT"))
.S ACRRR0=^ACRRR(ACRRRDA,0)
.S ACRRRDT=^ACRRR(ACRRRDA,"DT")
.S ACRSSDA=+ACRRR0
.Q:'$D(^ACRSS(+ACRSSDA,0))
.S ACRDUZ=$P(ACRRR0,U,5)
.S ACRRACP=$P(ACRRRDT,U,3)
.S ACRDATE=$P(ACRRRDT,U,4)
.S ACRDATE2=$P(ACRRR0,U,6)
.;S ACRDUZ=$P(^VA(200,ACRDUZ,0),U) ;ACR*2.1*19.02 IM16848
.S ACRDUZ=$$NAME2^ACRFUTL1(ACRDUZ) ;ACR*2.1*19.02 IM16848
.S ACRDUZ=$P($P(ACRDUZ,",",2)," ")_" "_$P(ACRDUZ,",")
.;S:"12"'[+$P(ACRRR0,U,8) (ACRDATE,ACRDATE2,ACRDUZ)="" ;ACR*2.1*16.15 IM16500
.D SETSS^ACRFSSA
.S ACROCDA=$P(ACRSS0,U,4)
.S ACROC=$P(^AUTTOBJC(ACROCDA,0),U)
.S ACRSNUM=$P(ACRSS0,U,14)
.D W
I $G(ACRDUZ)="",$D(^ACRDOC(ACRDOCDA,"REQ1")) D
.S ACRDUZ=$P(^ACRDOC(ACRDOCDA,"REQ1"),U,6)
.I ACRDUZ D
..;S ACRDUZ=$P($G(^VA(200,ACRDUZ,0)),U) ;ACR*2.1*19.02 IM16848
..S ACRDUZ=$$NAME2^ACRFUTL1(ACRDUZ) ;ACR*2.1*19.02 IM16848
..S ACRDUZ=$P($P(ACRDUZ,",",2)," ")_" "_$P(ACRDUZ,",")
S Y=ACRDATE
X ^DD("DD")
S ACRDATE=Y
S Y=ACRDATE2
X ^DD("DD")
S ACRDATE2=Y
Q
W W !,+ACRSS0
W ?6,$E($P(ACRSSDSC,U),1,25)
W ?34,ACROC
W ?39,$J(ACRRQD,6)
W ?46,ACRUI
W ?49,$J($FN(ACRUC,"P",2),10)
W ?60,$J($FN(ACRUC*ACRRACP,"P",2),12)
W ?73,$J(ACRRACP,6)
I ACRRACP<ACRRQD W ?79,$S($P(ACRRR0,U,8)=1:"F",$P(ACRRR0,U,8)=2:"P",1:"")
N J
F J=2:1:5 I $P(ACRSSDSC,U,J)]"" W !?3,$P(ACRSSDSC,U,J) D:J=2 SNUM
I $P(ACRSSDT,U,23) D
.S Y=$P(ACRSSDT,U,23)
.X ^DD("DD")
.W !?3,"EXPIRES ON: ",Y
.D SNUM
D SNUM
D NECOP^ACRFRRP1
W1 ;EP;
;I IOSL-4<$Y D PAUSE^ACRFWARN Q:$D(ACRQUIT) S ACRPAGE=ACRPAGE+1 S D0=ACRDOCDA N DXS,DIP,DC,DN D ^ACRRRH ;ACR*2.1*22.02 IM22606
I IOSL-4<$Y D PAUSE^ACRFWARN Q:$D(ACRQUIT) S ACRPAGE=$G(ACRPAGE)+1 S D0=ACRDOCDA N DXS,DIP,DC,DN D ^ACRRRH ;ACR*2.1*22.02 IM22606
Q
SNUM ;FORMAT AND PRINT FEDSTRIP SERIAL NUMBER
Q:'+ACRSNUM
S ACRX=""
S $P(ACRX,"0",7-$L(ACRSNUM))=""
S ACRSNUM=ACRX_ACRSNUM
W:$X>33 !
W ?34,ACRSNUM
S ACRSNUM=""
Q
RRNO ;EP;
D RRNO^ACRFRR31
I '$D(ACRDOC) D ;ACR*2.1*16.08 IM10140
.S ACRDOC=$S($P(ACRDOC0,U,2)]"":$P(ACRDOC0,U,2),1:$P(ACRDOC0,U)) ;ACR*2.1*16.08 IM10140
W !!,"There ",$S(ACRRRNO=1:"is ",1:"are "),$S(ACRRRNO:ACRRRNO,1:"NO")," receiving report",$S(ACRRRNO=1:"",1:"s")," on file for PO ",ACRDOC
I ACRRRNO<1 D PAUSE^ACRFWARN Q
I ACRRRNO=1 S Y=1 G D1
S DIR(0)="NOA^1:"_ACRRRNO
S DIR("A")="Select Receiving Report No.: "
W !
D DIR^ACRFDIC
Q:$D(ACRQUIT)!$D(ACROUT)!'Y
D1 S ACRRRNO=Y
S ACRFINAL=""
S ACRSSNO=$O(^ACRRR("AC",ACRDOCDA,ACRRRNO,0))
I ACRSSNO D
.S ACRRRDA=$O(^ACRRR("AC",ACRDOCDA,ACRRRNO,ACRSSNO,0))
.S:ACRRRDA ACRFINAL=$P(^ACRRR(ACRRRDA,0),U,8),ACRPVN=$P(^(0),U,13)
Q
RRPT ;EP;
K ACRPO
S ACRRR=""
S (ACRREF,ACRREFX)=499
S ZTIO=""
S ZTREQ="@"
S ACRPODA=$P(^ACRDOC(ACRDOCDA,0),U,8)
I ACRPODA,$D(^ACRPO(ACRPODA,0)) D
.S ZTIO1=$P(^ACRPO(ACRPODA,0),U,2)
.S ZTIO=$P(^ACRPO(ACRPODA,0),U,8)
.S ZTIO=$P(^AUTTPRG(ZTIO,"DT"),U,10)
.S (ACRRTN,ZTRTN)="^ACRFQ"
S:ZTIO ZTIO=$P($G(^%ZIS(1,ZTIO,0)),U)
S:ZTIO1 ZTIO1=$P($G(^%ZIS(1,ZTIO1,0)),U)
S ZTIO2=$P(^ACRPO(1,0),U,15)
S ZTIO3=$P(^ACRPO(1,0),U,16)
S ZTIO4=$P(^ACRPO(1,0),U,17)
S:ZTIO2 ZTIO2=$P($G(^%ZIS(1,ZTIO2,0)),U)
S:ZTIO4 ZTIO4=$P($G(^%ZIS(1,ZTIO4,0)),U)
I ZTIO3,$P(^ACRPO(1,0),U,20) D I 1
.S ZTIO3=$P(^AUTTPRG(ZTIO3,"DT"),U,10)
.S:ZTIO3 ZTIO3=$P($G(^%ZIS(1,ZTIO3,0)),U)
E S ZTIO3=""
S (ACRDESC,ZTDESC)="RR NO. "_ACRRRNO_" FOR PO NO. "_$P(ACRDOC0,U,2)
S (ACRDTH,ZTDTH)=$H
D:ZTIO]"" ZTLOAD
I ZTIO1]"" D
.S ZTIO=ZTIO1
.S ZTDESC=ACRDESC
.D ZTLOAD
I ZTIO3]"" D
.S ZTIO=ZTIO3
.S ZTDESC=ACRDESC
.D ZTLOAD
I ZTIO4]"" D
.Q
.S ZTIO=ZTIO4
.S ZTDESC=ACRDESC
.D ZTLOAD
D PROP
I $D(ACRQUIT),ZTIO2]"" D
.K ACRQUIT
.S ZTIO=ZTIO2
.S ZTDESC=ACRDESC_" (PROPERTY COPY)"
.D ZTLOAD
K ACRDESC,ACRRTN,ACRDTH
Q
ZTLOAD S ZTRTN=ACRRTN
S ZTDTH=ACRDTH
S ZTSAVE("ACR*")=""
S ZTREQ="@"
D ^%ZTLOAD
Q
PROP ;EP;TO PRINT REPORT TO AREA PROPERTY PRINTER
K ACRQUIT
N ACRSSDA
S ACRSSDA=0
F S ACRSSDA=$O(^ACRSS("J",ACRDOCDA,ACRSSDA)) Q:'ACRSSDA!$D(ACRQUIT) I $D(^ACRSS(ACRSSDA,0)) S ACROBJDA=$P(^(0),U,4) I ACROBJDA,$D(^AUTTOBJC(ACROBJDA,0)),$E(^(0),1,2)="31"!($E(^(0),1,3)="257"&("6AEJKLMNPQ"[$E(^(0),4))) S ACRQUIT=""
Q
499 ;EP;
S ACRRR=""
D PRINT^ACRFPO1
Q
REQOFF ;EP;TO PRINT LIST OF ADDITIONAL REQUESTING OFFICES FOR RECEIVING REPORT
N J,X,Y,Z,I,ACRX
S (X,J,I)=0
I '$D(ACRRR)#2 F S X=$O(^ACRSS("J",ACRDOCDA,X)) Q:'X I $D(^ACRSS(X,0)),$P(^(0),U,3)'=ACRDOCDA S Y=$P(^(0),U,3) D R1
I $D(ACRRR)#2,$D(ACRRRNO)#2,ACRRRNO F S J=$O(^ACRRR("AC",ACRDOCDA,ACRRRNO,J)) Q:'J S X=0 F S X=$O(^ACRRR("AC",ACRDOCDA,ACRRRNO,J,X)) Q:'X D
.I $D(^ACRRR(X,0)),+^(0),$D(^ACRSS(+^(0),0)),$P(^(0),U,3)'=ACRDOCDA S Y=$P(^(0),U,3) D R1
Q:'$D(ACRX)
W !!,"Additional REQUISITIONS with items on this PURCHASE ORDER:"
S X=""
F S X=$O(ACRX(X)) Q:X="" D
.S Y=""
.F S Y=$O(ACRX(X,Y)) Q:Y="" S Z=ACRX(X,Y) D
..I $D(ACRRR)#2 D I 1
...W !,X
...W ?20,Y
...W ?52
...S Z=$E(Z,1,$L(Z)-1)
...F I=1:1:$L(Z,",") W $P(Z,",",I),"," W:$X+$L($P(Z,",",I+1))>75 !?52
..E W !?63,X
..N X,Y
..D W1
Q
R1 S I=I+1
S Z=$P(^AUTTPRG($P(^ACRDOC(Y,"PO"),U,7),0),U)
S Y=$P(^ACRDOC(Y,0),U)
S:'$D(ACRX(Y,Z)) ACRX(Y,Z)=""
S ACRX(Y,Z)=ACRX(Y,Z)_I_","
Q
EN3 K ACROBJ
N Z,I
S (Z,I,ACRTOT)=0
F S Z=$O(^ACRRR("AC",ACRDOCDA,ACRRRNO,Z)) Q:'Z D
.S ACRRRDA=0
.F S ACRRRDA=$O(^ACRRR("AC",ACRDOCDA,ACRRRNO,Z,ACRRRDA)) Q:'ACRRRDA D
..Q:'$D(^ACRRR(ACRRRDA,0))!'$D(^ACRRR(ACRRRDA,"DT"))
..S ACRRR0=^ACRRR(ACRRRDA,0)
..S ACRRRDT=^ACRRR(ACRRRDA,"DT")
..S I=I+1
..S ^TMP("ACRRR",$J,I)=ACRRRDA
..S ACRSSDA=+ACRRR0
..I ACRSSDA,$D(^ACRSS(ACRSSDA,0)) D EN^ACRFRRP1
Q
ACRFRRPT ;IHS/OIRM/DSD/THL,AEF - RECEIVING REPORT; [ 11/7/2006 12:48 PM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**16,19,22**;NOV 05, 2001
+2 ;;ROUTINE TO PRINT THE RECEIVING REPORT
EN KILL ^TMP("ACRRR",$JOB)
+1 IF $DATA(ACRRR)#2
Begin DoDot:1
+2 SET ACRRRX=ACRRR
+3 KILL ACRRR
+4 SET ACRRR=ACRRRX
+5 KILL ACRRRX
End DoDot:1
+6 DO EN3
+7 DO PRINT^ACRFPSS
+8 DO EN1
EXIT KILL ACRRRDA,ACRQUIT,ACRDOCDX,ACRSNUM,^TMP("ACRRR",$JOB)
+1 QUIT
EN1 DO HEAD^ACRFRRP1
+1 NEW Z,ACRRRDA
+2 SET Z=0
+3 SET (ACRDATE,ACRDATE2)=""
+4 FOR
SET Z=$ORDER(^TMP("ACRRR",$JOB,Z))
IF 'Z!$DATA(ACRQUIT)
QUIT
Begin DoDot:1
+5 SET ACRRRDA=^TMP("ACRRR",$JOB,Z)
+6 IF 'ACRRRDA
QUIT
+7 IF '$DATA(^ACRRR(ACRRRDA,0))!'$DATA(^ACRRR(ACRRRDA,"DT"))
QUIT
+8 SET ACRRR0=^ACRRR(ACRRRDA,0)
+9 SET ACRRRDT=^ACRRR(ACRRRDA,"DT")
+10 SET ACRSSDA=+ACRRR0
+11 IF '$DATA(^ACRSS(+ACRSSDA,0))
QUIT
+12 SET ACRDUZ=$PIECE(ACRRR0,U,5)
+13 SET ACRRACP=$PIECE(ACRRRDT,U,3)
+14 SET ACRDATE=$PIECE(ACRRRDT,U,4)
+15 SET ACRDATE2=$PIECE(ACRRR0,U,6)
+16 ;S ACRDUZ=$P(^VA(200,ACRDUZ,0),U) ;ACR*2.1*19.02 IM16848
+17 ;ACR*2.1*19.02 IM16848
SET ACRDUZ=$$NAME2^ACRFUTL1(ACRDUZ)
+18 SET ACRDUZ=$PIECE($PIECE(ACRDUZ,",",2)," ")_" "_$PIECE(ACRDUZ,",")
+19 ;S:"12"'[+$P(ACRRR0,U,8) (ACRDATE,ACRDATE2,ACRDUZ)="" ;ACR*2.1*16.15 IM16500
+20 DO SETSS^ACRFSSA
+21 SET ACROCDA=$PIECE(ACRSS0,U,4)
+22 SET ACROC=$PIECE(^AUTTOBJC(ACROCDA,0),U)
+23 SET ACRSNUM=$PIECE(ACRSS0,U,14)
+24 DO W
End DoDot:1
+25 IF $GET(ACRDUZ)=""
IF $DATA(^ACRDOC(ACRDOCDA,"REQ1"))
Begin DoDot:1
+26 SET ACRDUZ=$PIECE(^ACRDOC(ACRDOCDA,"REQ1"),U,6)
+27 IF ACRDUZ
Begin DoDot:2
+28 ;S ACRDUZ=$P($G(^VA(200,ACRDUZ,0)),U) ;ACR*2.1*19.02 IM16848
+29 ;ACR*2.1*19.02 IM16848
SET ACRDUZ=$$NAME2^ACRFUTL1(ACRDUZ)
+30 SET ACRDUZ=$PIECE($PIECE(ACRDUZ,",",2)," ")_" "_$PIECE(ACRDUZ,",")
End DoDot:2
End DoDot:1
+31 SET Y=ACRDATE
+32 XECUTE ^DD("DD")
+33 SET ACRDATE=Y
+34 SET Y=ACRDATE2
+35 XECUTE ^DD("DD")
+36 SET ACRDATE2=Y
+37 QUIT
W WRITE !,+ACRSS0
+1 WRITE ?6,$EXTRACT($PIECE(ACRSSDSC,U),1,25)
+2 WRITE ?34,ACROC
+3 WRITE ?39,$JUSTIFY(ACRRQD,6)
+4 WRITE ?46,ACRUI
+5 WRITE ?49,$JUSTIFY($FNUMBER(ACRUC,"P",2),10)
+6 WRITE ?60,$JUSTIFY($FNUMBER(ACRUC*ACRRACP,"P",2),12)
+7 WRITE ?73,$JUSTIFY(ACRRACP,6)
+8 IF ACRRACP<ACRRQD
WRITE ?79,$SELECT($PIECE(ACRRR0,U,8)=1:"F",$PIECE(ACRRR0,U,8)=2:"P",1:"")
+9 NEW J
+10 FOR J=2:1:5
IF $PIECE(ACRSSDSC,U,J)]""
WRITE !?3,$PIECE(ACRSSDSC,U,J)
IF J=2
DO SNUM
+11 IF $PIECE(ACRSSDT,U,23)
Begin DoDot:1
+12 SET Y=$PIECE(ACRSSDT,U,23)
+13 XECUTE ^DD("DD")
+14 WRITE !?3,"EXPIRES ON: ",Y
+15 DO SNUM
End DoDot:1
+16 DO SNUM
+17 DO NECOP^ACRFRRP1
W1 ;EP;
+1 ;I IOSL-4<$Y D PAUSE^ACRFWARN Q:$D(ACRQUIT) S ACRPAGE=ACRPAGE+1 S D0=ACRDOCDA N DXS,DIP,DC,DN D ^ACRRRH ;ACR*2.1*22.02 IM22606
+2 ;ACR*2.1*22.02 IM22606
IF IOSL-4<$Y
DO PAUSE^ACRFWARN
IF $DATA(ACRQUIT)
QUIT
SET ACRPAGE=$GET(ACRPAGE)+1
SET D0=ACRDOCDA
NEW DXS,DIP,DC,DN
DO ^ACRRRH
+3 QUIT
SNUM ;FORMAT AND PRINT FEDSTRIP SERIAL NUMBER
+1 IF '+ACRSNUM
QUIT
+2 SET ACRX=""
+3 SET $PIECE(ACRX,"0",7-$LENGTH(ACRSNUM))=""
+4 SET ACRSNUM=ACRX_ACRSNUM
+5 IF $X>33
WRITE !
+6 WRITE ?34,ACRSNUM
+7 SET ACRSNUM=""
+8 QUIT
RRNO ;EP;
+1 DO RRNO^ACRFRR31
+2 ;ACR*2.1*16.08 IM10140
IF '$DATA(ACRDOC)
Begin DoDot:1
+3 ;ACR*2.1*16.08 IM10140
SET ACRDOC=$SELECT($PIECE(ACRDOC0,U,2)]"":$PIECE(ACRDOC0,U,2),1:$PIECE(ACRDOC0,U))
End DoDot:1
+4 WRITE !!,"There ",$SELECT(ACRRRNO=1:"is ",1:"are "),$SELECT(ACRRRNO:ACRRRNO,1:"NO")," receiving report",$SELECT(ACRRRNO=1:"",1:"s")," on file for PO ",ACRDOC
+5 IF ACRRRNO<1
DO PAUSE^ACRFWARN
QUIT
+6 IF ACRRRNO=1
SET Y=1
GOTO D1
+7 SET DIR(0)="NOA^1:"_ACRRRNO
+8 SET DIR("A")="Select Receiving Report No.: "
+9 WRITE !
+10 DO DIR^ACRFDIC
+11 IF $DATA(ACRQUIT)!$DATA(ACROUT)!'Y
QUIT
D1 SET ACRRRNO=Y
+1 SET ACRFINAL=""
+2 SET ACRSSNO=$ORDER(^ACRRR("AC",ACRDOCDA,ACRRRNO,0))
+3 IF ACRSSNO
Begin DoDot:1
+4 SET ACRRRDA=$ORDER(^ACRRR("AC",ACRDOCDA,ACRRRNO,ACRSSNO,0))
+5 IF ACRRRDA
SET ACRFINAL=$PIECE(^ACRRR(ACRRRDA,0),U,8)
SET ACRPVN=$PIECE(^(0),U,13)
End DoDot:1
+6 QUIT
RRPT ;EP;
+1 KILL ACRPO
+2 SET ACRRR=""
+3 SET (ACRREF,ACRREFX)=499
+4 SET ZTIO=""
+5 SET ZTREQ="@"
+6 SET ACRPODA=$PIECE(^ACRDOC(ACRDOCDA,0),U,8)
+7 IF ACRPODA
IF $DATA(^ACRPO(ACRPODA,0))
Begin DoDot:1
+8 SET ZTIO1=$PIECE(^ACRPO(ACRPODA,0),U,2)
+9 SET ZTIO=$PIECE(^ACRPO(ACRPODA,0),U,8)
+10 SET ZTIO=$PIECE(^AUTTPRG(ZTIO,"DT"),U,10)
+11 SET (ACRRTN,ZTRTN)="^ACRFQ"
End DoDot:1
+12 IF ZTIO
SET ZTIO=$PIECE($GET(^%ZIS(1,ZTIO,0)),U)
+13 IF ZTIO1
SET ZTIO1=$PIECE($GET(^%ZIS(1,ZTIO1,0)),U)
+14 SET ZTIO2=$PIECE(^ACRPO(1,0),U,15)
+15 SET ZTIO3=$PIECE(^ACRPO(1,0),U,16)
+16 SET ZTIO4=$PIECE(^ACRPO(1,0),U,17)
+17 IF ZTIO2
SET ZTIO2=$PIECE($GET(^%ZIS(1,ZTIO2,0)),U)
+18 IF ZTIO4
SET ZTIO4=$PIECE($GET(^%ZIS(1,ZTIO4,0)),U)
+19 IF ZTIO3
IF $PIECE(^ACRPO(1,0),U,20)
Begin DoDot:1
+20 SET ZTIO3=$PIECE(^AUTTPRG(ZTIO3,"DT"),U,10)
+21 IF ZTIO3
SET ZTIO3=$PIECE($GET(^%ZIS(1,ZTIO3,0)),U)
End DoDot:1
IF 1
+22 IF '$TEST
SET ZTIO3=""
+23 SET (ACRDESC,ZTDESC)="RR NO. "_ACRRRNO_" FOR PO NO. "_$PIECE(ACRDOC0,U,2)
+24 SET (ACRDTH,ZTDTH)=$HOROLOG
+25 IF ZTIO]""
DO ZTLOAD
+26 IF ZTIO1]""
Begin DoDot:1
+27 SET ZTIO=ZTIO1
+28 SET ZTDESC=ACRDESC
+29 DO ZTLOAD
End DoDot:1
+30 IF ZTIO3]""
Begin DoDot:1
+31 SET ZTIO=ZTIO3
+32 SET ZTDESC=ACRDESC
+33 DO ZTLOAD
End DoDot:1
+34 IF ZTIO4]""
Begin DoDot:1
+35 QUIT
+36 SET ZTIO=ZTIO4
+37 SET ZTDESC=ACRDESC
+38 DO ZTLOAD
End DoDot:1
+39 DO PROP
+40 IF $DATA(ACRQUIT)
IF ZTIO2]""
Begin DoDot:1
+41 KILL ACRQUIT
+42 SET ZTIO=ZTIO2
+43 SET ZTDESC=ACRDESC_" (PROPERTY COPY)"
+44 DO ZTLOAD
End DoDot:1
+45 KILL ACRDESC,ACRRTN,ACRDTH
+46 QUIT
ZTLOAD SET ZTRTN=ACRRTN
+1 SET ZTDTH=ACRDTH
+2 SET ZTSAVE("ACR*")=""
+3 SET ZTREQ="@"
+4 DO ^%ZTLOAD
+5 QUIT
PROP ;EP;TO PRINT REPORT TO AREA PROPERTY PRINTER
+1 KILL ACRQUIT
+2 NEW ACRSSDA
+3 SET ACRSSDA=0
+4 FOR
SET ACRSSDA=$ORDER(^ACRSS("J",ACRDOCDA,ACRSSDA))
IF 'ACRSSDA!$DATA(ACRQUIT)
QUIT
IF $DATA(^ACRSS(ACRSSDA,0))
SET ACROBJDA=$PIECE(^(0),U,4)
IF ACROBJDA
IF $DATA(^AUTTOBJC(ACROBJDA,0))
IF $EXTRACT(^(0),1,2)="31"!($EXTRACT(^(0),1,3)="257"&("6AEJKLMNPQ"[$EXTRACT(^(0),4)))
SET ACRQUIT=""
+5 QUIT
499 ;EP;
+1 SET ACRRR=""
+2 DO PRINT^ACRFPO1
+3 QUIT
REQOFF ;EP;TO PRINT LIST OF ADDITIONAL REQUESTING OFFICES FOR RECEIVING REPORT
+1 NEW J,X,Y,Z,I,ACRX
+2 SET (X,J,I)=0
+3 IF '$DATA(ACRRR)#2
FOR
SET X=$ORDER(^ACRSS("J",ACRDOCDA,X))
IF 'X
QUIT
IF $DATA(^ACRSS(X,0))
IF $PIECE(^(0),U,3)'=ACRDOCDA
SET Y=$PIECE(^(0),U,3)
DO R1
+4 IF $DATA(ACRRR)#2
IF $DATA(ACRRRNO)#2
IF ACRRRNO
FOR
SET J=$ORDER(^ACRRR("AC",ACRDOCDA,ACRRRNO,J))
IF 'J
QUIT
SET X=0
FOR
SET X=$ORDER(^ACRRR("AC",ACRDOCDA,ACRRRNO,J,X))
IF 'X
QUIT
Begin DoDot:1
+5 IF $DATA(^ACRRR(X,0))
IF +^(0)
IF $DATA(^ACRSS(+^(0),0))
IF $PIECE(^(0),U,3)'=ACRDOCDA
SET Y=$PIECE(^(0),U,3)
DO R1
End DoDot:1
+6 IF '$DATA(ACRX)
QUIT
+7 WRITE !!,"Additional REQUISITIONS with items on this PURCHASE ORDER:"
+8 SET X=""
+9 FOR
SET X=$ORDER(ACRX(X))
IF X=""
QUIT
Begin DoDot:1
+10 SET Y=""
+11 FOR
SET Y=$ORDER(ACRX(X,Y))
IF Y=""
QUIT
SET Z=ACRX(X,Y)
Begin DoDot:2
+12 IF $DATA(ACRRR)#2
Begin DoDot:3
+13 WRITE !,X
+14 WRITE ?20,Y
+15 WRITE ?52
+16 SET Z=$EXTRACT(Z,1,$LENGTH(Z)-1)
+17 FOR I=1:1:$LENGTH(Z,",")
WRITE $PIECE(Z,",",I),","
IF $X+$LENGTH($PIECE(Z,",",I+1))>75
WRITE !?52
End DoDot:3
IF 1
+18 IF '$TEST
WRITE !?63,X
+19 NEW X,Y
+20 DO W1
End DoDot:2
End DoDot:1
+21 QUIT
R1 SET I=I+1
+1 SET Z=$PIECE(^AUTTPRG($PIECE(^ACRDOC(Y,"PO"),U,7),0),U)
+2 SET Y=$PIECE(^ACRDOC(Y,0),U)
+3 IF '$DATA(ACRX(Y,Z))
SET ACRX(Y,Z)=""
+4 SET ACRX(Y,Z)=ACRX(Y,Z)_I_","
+5 QUIT
EN3 KILL ACROBJ
+1 NEW Z,I
+2 SET (Z,I,ACRTOT)=0
+3 FOR
SET Z=$ORDER(^ACRRR("AC",ACRDOCDA,ACRRRNO,Z))
IF 'Z
QUIT
Begin DoDot:1
+4 SET ACRRRDA=0
+5 FOR
SET ACRRRDA=$ORDER(^ACRRR("AC",ACRDOCDA,ACRRRNO,Z,ACRRRDA))
IF 'ACRRRDA
QUIT
Begin DoDot:2
+6 IF '$DATA(^ACRRR(ACRRRDA,0))!'$DATA(^ACRRR(ACRRRDA,"DT"))
QUIT
+7 SET ACRRR0=^ACRRR(ACRRRDA,0)
+8 SET ACRRRDT=^ACRRR(ACRRRDA,"DT")
+9 SET I=I+1
+10 SET ^TMP("ACRRR",$JOB,I)=ACRRRDA
+11 SET ACRSSDA=+ACRRR0
+12 IF ACRSSDA
IF $DATA(^ACRSS(ACRSSDA,0))
DO EN^ACRFRRP1
End DoDot:2
End DoDot:1
+13 QUIT
