- 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
