ACRFDI ;IHS/OIRM/DSD/THL,AEF - DUE IN REPORT; [ 02/02/2005 1:01 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**16**;NOV 05, 2001
;;ROUTINE USED TO PRINT DUI IN REPORTS
EN D SHIPTO^ACRFRR
Q:$D(ACRQUIT)!$D(ACROUT)!'$D(ACRRL)
D DUE
Q:$D(ACRQUIT)!$D(ACROUT)!'$D(ACRDAT)!'$D(ACRBEFOR)
D ZIS
EXIT K ACRDAT,ACRJ,ACRDUET,ACRX,ACRQUIT,ACRDOCDA,ACRLATE,ACRDAT1,ACRBEFOR,ACRAFTER,ACRUI,ACRINDEX,ACRDAYS,ACRDSC1,ACRDSC2,ACRQTY,ACRDIR,ACRDOC1,ACR,ACRRTN,ACRRL
Q
ZIS S ZTDESC="ARMS DUE IN REPORT"
S ACRRTN="LIST^ACRFDI"
D ^ACRFZIS
Q
LIST ;EP;TO PRINT DUE IN REPORT
D HEAD
S ACRJ=0
F S ACRDAT=$O(^ACRDOC("DI",ACRRL,ACRDAT)) Q:'ACRDAT!$D(ACRQUIT)!$D(ACROUT)!(ACRDAT>ACRBEFOR) D LIST1
I 'ACRJ W !?10,"There are NO PO'S ",$G(ACRDUET)
D PAUSE^ACRFWARN
K ACRQUIT
Q
LIST1 D DAT
N DATA
Q:$D(ACRQUIT)!$D(ACROUT)
S ACRJ=ACRJ+1,ACRDOCDA=0
F S ACRDOCDA=$O(^ACRDOC("DI",ACRRL,ACRDAT,ACRDOCDA)) Q:'ACRDOCDA!$D(ACRQUIT)!$D(ACROUT) D
. Q:'$D(^ACRSS("J",ACRDOCDA))
. S DATA=$G(^ACRDOC(ACRDOCDA,0))
. Q:$P(DATA,U,4)=35 ; cc purchase
. Q:$P(DATA,U,12) ; draft payment
. Q:$P(DATA,U,18) ; total dollars for BPA
. S DATA=$G(^ACROBL(ACRDOCDA,"APV"))
. Q:$P(DATA,U)'="A" ; request approved
. Q:$P(DATA,U,8)'="A" ; PO authorized
. Q:$P(DATA,U,6)=1 ; 1=final RR
. Q:$P(DATA,U,9)=1 ; 1=final invoice
. D DOC1
Q
DAT K ACRQUIT
S ACRDAT1=$E(ACRDAT,4,5)_"/"_$E(ACRDAT,6,7)_"/"_$E(ACRDAT,2,3)
S X1=$S(ACRBEFOR=9999999:DT,1:ACRBEFOR)
S X2=ACRDAT
Q:ACRDUET["DUE BETWEEN"
D ^%DTC
K X1,X2
I X<ACRDAYS S ACRQUIT="" Q
S ACRLATE=X
Q
DOC1 N X
S X=^ACRDOC(ACRDOCDA,0)
S ACRDOC=$E($P(X,U,2),1,10)
S ACRDOC1=$P(X,U)
I ACRDOC="" S ACRDOC=ACRDOC1 ;ACR*2.1*16.04 IM11579
S:$P(X,U,9) ACRDOC=ACRDOC_"-MOD"_+$P(X,U,9)
;W !,ACRDOC ;ACR*2.1*16.04 IM11579
N ACRHD ;ACR*2.1*16.04 IM11579
S ACRHD=1 ;ACR*2.1*16.04 IM11579
S (ACRSSDA,ACRJ)=0
F S ACRSSDA=$O(^ACRSS("J",ACRDOCDA,ACRSSDA)) Q:'ACRSSDA!$D(ACRQUIT)!$D(ACROUT) D SS1
Q
SS1 S ACRINDEX=$P($G(^ACRSS(ACRSSDA,"NMS")),U,4)
S ACRUI=^ACRSS(ACRSSDA,"DT")
S ACRQTY=$P(ACRUI,U)
S ACRUI=$P(ACRUI,U,2)
S ACRDSC1=$G(^ACRSS(ACRSSDA,"DESC"))
S ACRDSC2=$E($P(ACRDSC1,U,2),1,30)
S ACRDSC1=$E($P(ACRDSC1,U),1,30)
S ACRUI=$S($D(^ACRUI(+ACRUI,0)):$P(^(0),U),1:"**")
D QADJST
Q:ACRQTY<1
I ACRHD W !,ACRDOC S ACRHD=0 ;ACR*2.1*16.04 IM11579
S ACRJ=ACRJ+1
W W:ACRJ>1 !
W ?17,ACRINDEX
W ?24,ACRDSC1
W ?55,ACRUI
W ?58,$J(ACRQTY,4)
W ?63,$J($G(ACRLATE),4)
I ACRJ=1 D
.W ?68,ACRDAT1
.W !?3,"(",ACRDOC1,")"
I ACRDSC2]"" W:ACRJ>1 ! W ?24,ACRDSC2
D:$Y#IOSL>20 PAUSE^ACRFWARN
Q
DUE S (ACRDIR,DIR(0))="SO^1:DUE NOW;2:7 DAYS PAST DUE;3:30 DAYS PAST DUE;4:DUE BETWEEN DATES"
D DIR^ACRFDIC
I "1234"'[+Y S ACRQUIT="" Q
S ACRDUET=$P($P($P(ACRDIR,U,2),";",X),":",2)
I Y<4 D
.S X2=$S(X=1:0,X=2:-7,3:-30)
.S X1=DT
.S ACRDAYS=X2*-1
.S ACRDAT=0
.D C^%DTC
.S ACRBEFOR=(X-1)
I Y=4 D DATES
Q
HEAD W @IOF
W !?17,"DUE IN REPORT"
W !?17,"RECEIVING LOCATION: ",$P($G(^AUTTPRG(+$G(ACRRL),0)),U)
W !?17,"REPORT DATE.......: "
S Y=DT
X ^DD("DD")
W Y
W !?17,"REPORT FOR ORDERS.: ",$G(ACRDUET)
W !!?58,"DUE"
W ?63,"NO."
W ?77,"STO"
W !?17,"INDEX"
W ?58,"IN"
W ?63,"DAYS"
W ?68,"DATE"
W ?77,"RES"
W !,"PO NUMBER"
W ?17,"NUMBER"
W ?24,"DESCRIPTION"
W ?55,"UI"
W ?58,"QTY"
W ?63,"LATE"
W ?68,"DUE IN"
W ?77,"ITM"
W !,"----------------"
W ?17,"------"
W ?24,"------------------------------"
W ?55,"--"
W ?58,"----"
W ?63,"----"
W ?68,"--------"
W ?77,"---"
Q
DATES ;EP;TO DETERMINE DATES DURING WHICH ITEMS ARE DUE IN
S DIR(0)="DO^::AE"
S DIR("A")="Delivery Due On or After"
D DIR^ACRFDIC
Q:$D(ACRQUIT)!$D(ACROUT)!'$D(Y)
S ACRDAT=+Y-1
S DIR(0)="DO^::AE"
S DIR("A")="Delivery Due On or Before"
D DIR^ACRFDIC
Q:$D(ACRQUIT)!$D(ACROUT)!'$D(Y)
S (X1,ACRBEFOR)=+Y
S X2=DT
D ^%DTC
S ACRDAYS=X
Q
QADJST ;ADJUST QUANTITY ORDERED BY DELETING QUANTITY ALREADY ACCEPTED
N ACRRRDA
S ACRRRDA=0
F S ACRRRDA=$O(^ACRRR("B",ACRSSDA,ACRRRDA)) Q:'ACRRRDA D
.I $D(^ACRRR(ACRRRDA,"DT")) S ACRQTY=ACRQTY-$P(^("DT"),U,3)
Q
ACRFDI ;IHS/OIRM/DSD/THL,AEF - DUE IN REPORT; [ 02/02/2005 1:01 PM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**16**;NOV 05, 2001
+2 ;;ROUTINE USED TO PRINT DUI IN REPORTS
EN DO SHIPTO^ACRFRR
+1 IF $DATA(ACRQUIT)!$DATA(ACROUT)!'$DATA(ACRRL)
QUIT
+2 DO DUE
+3 IF $DATA(ACRQUIT)!$DATA(ACROUT)!'$DATA(ACRDAT)!'$DATA(ACRBEFOR)
QUIT
+4 DO ZIS
EXIT KILL ACRDAT,ACRJ,ACRDUET,ACRX,ACRQUIT,ACRDOCDA,ACRLATE,ACRDAT1,ACRBEFOR,ACRAFTER,ACRUI,ACRINDEX,ACRDAYS,ACRDSC1,ACRDSC2,ACRQTY,ACRDIR,ACRDOC1,ACR,ACRRTN,ACRRL
+1 QUIT
ZIS SET ZTDESC="ARMS DUE IN REPORT"
+1 SET ACRRTN="LIST^ACRFDI"
+2 DO ^ACRFZIS
+3 QUIT
LIST ;EP;TO PRINT DUE IN REPORT
+1 DO HEAD
+2 SET ACRJ=0
+3 FOR
SET ACRDAT=$ORDER(^ACRDOC("DI",ACRRL,ACRDAT))
IF 'ACRDAT!$DATA(ACRQUIT)!$DATA(ACROUT)!(ACRDAT>ACRBEFOR)
QUIT
DO LIST1
+4 IF 'ACRJ
WRITE !?10,"There are NO PO'S ",$GET(ACRDUET)
+5 DO PAUSE^ACRFWARN
+6 KILL ACRQUIT
+7 QUIT
LIST1 DO DAT
+1 NEW DATA
+2 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+3 SET ACRJ=ACRJ+1
SET ACRDOCDA=0
+4 FOR
SET ACRDOCDA=$ORDER(^ACRDOC("DI",ACRRL,ACRDAT,ACRDOCDA))
IF 'ACRDOCDA!$DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
Begin DoDot:1
+5 IF '$DATA(^ACRSS("J",ACRDOCDA))
QUIT
+6 SET DATA=$GET(^ACRDOC(ACRDOCDA,0))
+7 ; cc purchase
IF $PIECE(DATA,U,4)=35
QUIT
+8 ; draft payment
IF $PIECE(DATA,U,12)
QUIT
+9 ; total dollars for BPA
IF $PIECE(DATA,U,18)
QUIT
+10 SET DATA=$GET(^ACROBL(ACRDOCDA,"APV"))
+11 ; request approved
IF $PIECE(DATA,U)'="A"
QUIT
+12 ; PO authorized
IF $PIECE(DATA,U,8)'="A"
QUIT
+13 ; 1=final RR
IF $PIECE(DATA,U,6)=1
QUIT
+14 ; 1=final invoice
IF $PIECE(DATA,U,9)=1
QUIT
+15 DO DOC1
End DoDot:1
+16 QUIT
DAT KILL ACRQUIT
+1 SET ACRDAT1=$EXTRACT(ACRDAT,4,5)_"/"_$EXTRACT(ACRDAT,6,7)_"/"_$EXTRACT(ACRDAT,2,3)
+2 SET X1=$SELECT(ACRBEFOR=9999999:DT,1:ACRBEFOR)
+3 SET X2=ACRDAT
+4 IF ACRDUET["DUE BETWEEN"
QUIT
+5 DO ^%DTC
+6 KILL X1,X2
+7 IF X<ACRDAYS
SET ACRQUIT=""
QUIT
+8 SET ACRLATE=X
+9 QUIT
DOC1 NEW X
+1 SET X=^ACRDOC(ACRDOCDA,0)
+2 SET ACRDOC=$EXTRACT($PIECE(X,U,2),1,10)
+3 SET ACRDOC1=$PIECE(X,U)
+4 ;ACR*2.1*16.04 IM11579
IF ACRDOC=""
SET ACRDOC=ACRDOC1
+5 IF $PIECE(X,U,9)
SET ACRDOC=ACRDOC_"-MOD"_+$PIECE(X,U,9)
+6 ;W !,ACRDOC ;ACR*2.1*16.04 IM11579
+7 ;ACR*2.1*16.04 IM11579
NEW ACRHD
+8 ;ACR*2.1*16.04 IM11579
SET ACRHD=1
+9 SET (ACRSSDA,ACRJ)=0
+10 FOR
SET ACRSSDA=$ORDER(^ACRSS("J",ACRDOCDA,ACRSSDA))
IF 'ACRSSDA!$DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
DO SS1
+11 QUIT
SS1 SET ACRINDEX=$PIECE($GET(^ACRSS(ACRSSDA,"NMS")),U,4)
+1 SET ACRUI=^ACRSS(ACRSSDA,"DT")
+2 SET ACRQTY=$PIECE(ACRUI,U)
+3 SET ACRUI=$PIECE(ACRUI,U,2)
+4 SET ACRDSC1=$GET(^ACRSS(ACRSSDA,"DESC"))
+5 SET ACRDSC2=$EXTRACT($PIECE(ACRDSC1,U,2),1,30)
+6 SET ACRDSC1=$EXTRACT($PIECE(ACRDSC1,U),1,30)
+7 SET ACRUI=$SELECT($DATA(^ACRUI(+ACRUI,0)):$PIECE(^(0),U),1:"**")
+8 DO QADJST
+9 IF ACRQTY<1
QUIT
+10 ;ACR*2.1*16.04 IM11579
IF ACRHD
WRITE !,ACRDOC
SET ACRHD=0
+11 SET ACRJ=ACRJ+1
W IF ACRJ>1
WRITE !
+1 WRITE ?17,ACRINDEX
+2 WRITE ?24,ACRDSC1
+3 WRITE ?55,ACRUI
+4 WRITE ?58,$JUSTIFY(ACRQTY,4)
+5 WRITE ?63,$JUSTIFY($GET(ACRLATE),4)
+6 IF ACRJ=1
Begin DoDot:1
+7 WRITE ?68,ACRDAT1
+8 WRITE !?3,"(",ACRDOC1,")"
End DoDot:1
+9 IF ACRDSC2]""
IF ACRJ>1
WRITE !
WRITE ?24,ACRDSC2
+10 IF $Y#IOSL>20
DO PAUSE^ACRFWARN
+11 QUIT
DUE SET (ACRDIR,DIR(0))="SO^1:DUE NOW;2:7 DAYS PAST DUE;3:30 DAYS PAST DUE;4:DUE BETWEEN DATES"
+1 DO DIR^ACRFDIC
+2 IF "1234"'[+Y
SET ACRQUIT=""
QUIT
+3 SET ACRDUET=$PIECE($PIECE($PIECE(ACRDIR,U,2),";",X),":",2)
+4 IF Y<4
Begin DoDot:1
+5 SET X2=$SELECT(X=1:0,X=2:-7,3:-30)
+6 SET X1=DT
+7 SET ACRDAYS=X2*-1
+8 SET ACRDAT=0
+9 DO C^%DTC
+10 SET ACRBEFOR=(X-1)
End DoDot:1
+11 IF Y=4
DO DATES
+12 QUIT
HEAD WRITE @IOF
+1 WRITE !?17,"DUE IN REPORT"
+2 WRITE !?17,"RECEIVING LOCATION: ",$PIECE($GET(^AUTTPRG(+$GET(ACRRL),0)),U)
+3 WRITE !?17,"REPORT DATE.......: "
+4 SET Y=DT
+5 XECUTE ^DD("DD")
+6 WRITE Y
+7 WRITE !?17,"REPORT FOR ORDERS.: ",$GET(ACRDUET)
+8 WRITE !!?58,"DUE"
+9 WRITE ?63,"NO."
+10 WRITE ?77,"STO"
+11 WRITE !?17,"INDEX"
+12 WRITE ?58,"IN"
+13 WRITE ?63,"DAYS"
+14 WRITE ?68,"DATE"
+15 WRITE ?77,"RES"
+16 WRITE !,"PO NUMBER"
+17 WRITE ?17,"NUMBER"
+18 WRITE ?24,"DESCRIPTION"
+19 WRITE ?55,"UI"
+20 WRITE ?58,"QTY"
+21 WRITE ?63,"LATE"
+22 WRITE ?68,"DUE IN"
+23 WRITE ?77,"ITM"
+24 WRITE !,"----------------"
+25 WRITE ?17,"------"
+26 WRITE ?24,"------------------------------"
+27 WRITE ?55,"--"
+28 WRITE ?58,"----"
+29 WRITE ?63,"----"
+30 WRITE ?68,"--------"
+31 WRITE ?77,"---"
+32 QUIT
DATES ;EP;TO DETERMINE DATES DURING WHICH ITEMS ARE DUE IN
+1 SET DIR(0)="DO^::AE"
+2 SET DIR("A")="Delivery Due On or After"
+3 DO DIR^ACRFDIC
+4 IF $DATA(ACRQUIT)!$DATA(ACROUT)!'$DATA(Y)
QUIT
+5 SET ACRDAT=+Y-1
+6 SET DIR(0)="DO^::AE"
+7 SET DIR("A")="Delivery Due On or Before"
+8 DO DIR^ACRFDIC
+9 IF $DATA(ACRQUIT)!$DATA(ACROUT)!'$DATA(Y)
QUIT
+10 SET (X1,ACRBEFOR)=+Y
+11 SET X2=DT
+12 DO ^%DTC
+13 SET ACRDAYS=X
+14 QUIT
QADJST ;ADJUST QUANTITY ORDERED BY DELETING QUANTITY ALREADY ACCEPTED
+1 NEW ACRRRDA
+2 SET ACRRRDA=0
+3 FOR
SET ACRRRDA=$ORDER(^ACRRR("B",ACRSSDA,ACRRRDA))
IF 'ACRRRDA
QUIT
Begin DoDot:1
+4 IF $DATA(^ACRRR(ACRRRDA,"DT"))
SET ACRQTY=ACRQTY-$PIECE(^("DT"),U,3)
End DoDot:1
+5 QUIT
