Routine: ACRFDI

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

ZIS S ZTDESC="ARMS DUE IN REPORT"

 S ACRRTN="LIST^ACRFDI"

 D ^ACRFZIS

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

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

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

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

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

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

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,"---"

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

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)

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

ACRFDI.m