ACRFBPA.m

ACRFBPA ;IHS/OIRM/DSD/THL,AEF - BPA MANAGEMENT; [ 10/27/2004   4:15 PM ]

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

 ;;MANAGE VARIOUS ASPECTS OF BLANKET PURCHASE AGREEMENTS

CHOOSE ;EP;

 K ACRBPA,DIC,ACRDOC

 S DIC="^ACRDOC("

 S DIC(0)="AENMQZ"

 S DIC("A")="Which BLANKET PURCHASE AGREEMENT: "

 S DIC("S")="S ACRDOC0=$G(^ACRDOC(+Y,0)),ACRCDATE=$P($G(^(15)),U,11),ACRAPV=$G(^ACROBL(+Y,""APV""))"

 S DIC("S")=DIC("S")_" I '$P(ACRDOC0,U,15),$S($D(ACRBPASM):1,1:($D(^ACRDOC(+Y,6,""B"",DUZ))!$D(^ACRDOC(+Y,50,""B"",DUZ)))&$P(ACRDOC0,U,23)),$S(ACRCDATE&$D(ACRNEWOB):ACRCDATE>DT,1:1),$P(ACRDOC0,U,18)>0,$P(ACRDOC0,U,16),$P(ACRAPV,U,8)=""A"""

 S D="T"

 W !

 D DIC^ACRFDIC

 I +Y'>0 S ACRQUIT="" Q

 I $$LASTBPA^ACRFNEW1(+Y) D  Q              ; ACR*2.1*14.03 IM13538

 . W *7,*7,!!?10,"ALL CALL NUMBERS FOR THIS BPA HAVE BEEN USED!"

 . D PAUSE^ACRFWARN

 . S ACRQUIT=""

 S ACRBPA=+Y

 S ACRBPA0=^ACRDOC(+Y,0)

 S ACRBPAPO=^ACRDOC(+Y,"PO")

 S ACRBPAPA=^ACRDOC(+Y,"PA")

 S ACRBPAV=$P(ACRBPAPO,U,5)

 S ACRBPATX=$P(ACRBPA0,U,4)

 S ACRBPAPS=$P(ACRBPAPA,U,3)

 S ACRBPASP=$P(ACRBPA0,U,16)

 S ACRBPATO=$P(ACRBPAPO,U,6)

 S ACRBPAFO=$P(ACRBPAPO,U,9)

 S ACRPONUM=$P(ACRBPA0,U,2)

 I '$D(^ACRDOC(ACRBPA,3))!'$P($G(^ACRDOC(ACRBPA,3)),U,10) D  Q

 .W !!,*7,*7,"BPA Call Limit not set for this BPA.  Call Procurement for assistance."

 .D PAUSE^ACRFWARN

 .S ACRQUIT=""

 K ACRBPA0,ACRBPAPO,ACRBPAPA

 Q:$D(ACRBPASM)

 W !!,"Please hold for a moment while I determine the"

 W !,"total amount charged against this BPA to date."

 D BS

 S DIR(0)="DOA"

 S DIR("A")="ORDER DATE..........: "

 S DIR("B")="TODAY"

 D DIR^ACRFDIC

 I 'Y!$D(ACRQUIT)!$D(ACROUT) S ACRQUIT="" Q

 S (X1,ACROD)=Y

 S X2=45

 D C^%DTC

 S Y=X

 X ^DD("DD")

 S DIR("B")=Y

 S DIR(0)="DOA"

 S DIR("A")="DATE REQUIRED.......: "

 D DIR^ACRFDIC

 I 'Y!$D(ACRQUIT)!$D(ACROUT) S ACRQUIT="" Q

 S ACRRQDD=Y

 Q

BPASUM ;EP;TO SUMMARIZE TOTAL DOLLARS OBLIGATED AGAINST A BPA

 D ^XBKVAR

 S ACRBPASM=""

 D CHOOSE

 Q:'$D(ACRBPA)

 Q:'ACRBPA

 S ACRDOCDA=ACRBPA

 S DIR(0)="YO"

 S DIR("A")="Print list of all Calls"

 S DIR("B")="NO"

 S DIR("?")="Enter 'Y' if you want a list of all calls against this BPA"

 W !

 D DIR^ACRFDIC

 Q:$D(ACRQUIT)!$D(ACROUT)

 S ACRDOC=$S(Y=1:"YES",1:"")

 S ACRRTN="BS^ACRFBPA"

 S ZTDESC="BPA SUMMARY"

 D ^ACRFZIS

 Q

BS ;EP;TO PRINT BPA SUMMARY

 N DATA

 K ^TMP("ACRF",$J,"ACRDOC")

 S (ACRDOCDA,ACRREQ,ACROBL,ACRSPT,ACRJ)=0

 K ACRBPASM

 F  S ACRDOCDA=$O(^ACRDOC("BPA",ACRBPA,ACRDOCDA)) Q:'ACRDOCDA  I $D(^ACRSS("J",ACRDOCDA)) D

 .S ACRJ=ACRJ+1

 .S ACRSPT=ACRSPT+$P(^ACROBL(ACRDOCDA,"DT"),U,2)

 .S ACRSSDA=0

 .F  S ACRSSDA=$O(^ACRSS("J",ACRDOCDA,ACRSSDA)) Q:'ACRSSDA  I $D(^ACRSS(ACRSSDA,0)),$D(^("DT")) S ACRSSDT=^("DT") D

 ..S ACRREQ=ACRREQ+$P(ACRSSDT,U,4)

 ..S ACROBL=ACROBL+$P(ACRSSDT,U,9)

 ..I $D(ACRDOC)#2,ACRDOC="YES" D

 ...S DATA=$G(^ACRDOC(ACRDOCDA,0))

 ...Q:'$P(DATA,U,2)

 ...S ^TMP("ACRF",$J,"ACRDOC"," "_$E($P(DATA,U,2),9,10),ACRJ)=$P(DATA,U)_U_ACRDOCDA_U_$P(DATA,U,2)

 S ACRBPAA=$P(^ACRDOC(ACRBPA,0),U,18)

 S ACRDOC=$P(^ACRDOC(ACRBPA,0),U,2)

 W:$E($G(IOST),1,2)="C-" @IOF

 W !!?10,"TOTAL DOLLARS COMMITTED AND OBLIGATED AGAINST BPA: ",ACRDOC

 W !?10,"------------------------------------------------------------------"

 W !?10,"TOTAL SET ASIDE:"

 W ?27,"TOTAL COMMITTED:"

 W ?44,"TOTAL OBLIGATED:"

 W ?62,"TOTAL SPENT"

 W !?10,"---------------"

 W ?27,"---------------"

 W ?44,"---------------"

 W ?62,"--------------"

 W !?10,$J($FN(ACRBPAA,"P,",2),14)

 W ?27,$J($FN(ACRREQ,"P,",2),14)

 W ?44,$J($FN(ACROBL,"P,",2),14)

 W ?62,$J($FN(ACRSPT,"P,",2),14)

 D PAUSE^ACRFWARN

 I $D(^TMP("ACRF",$J,"ACRDOC")) D

 .D PH

 .S ACR=""

 .F  S ACR=$O(^TMP("ACRF",$J,"ACRDOC",ACR)) Q:ACR=""!$D(ACRQUIT)  D

 ..S ACRJ=0

 ..F  S ACRJ=$O(^TMP("ACRF",$J,"ACRDOC",ACR,ACRJ)) Q:'ACRJ!$D(ACRQUIT)  D

 ...S DATA=^TMP("ACRF",$J,"ACRDOC",ACR,ACRJ)

 ...S ACRDOCDA=$P(DATA,U,2)

 ...S ACRDOCX=$O(^ACRDHR("E",ACRDOCDA,0))

 ...I ACRDOCX S ACRDOCX=$P($G(^ACRDHR(ACRDOCX,0)),U)

 ...W !?4,$P(DATA,U,2)

 ...W ?10,ACR

 ...W ?15,$P(DATA,U)

 ...W ?35,$P(DATA,U,3)

 ...I ACRDOCX'=$P(DATA,U,3) W ?55,ACRDOCX

 ...D P

 D PAUSE^ACRFWARN

 W @IOF

 K ^TMP("ACRF",$J,"ACRDOC")

 Q

P ;

 I IOSL-4<$Y,$O(^TMP("ACRF",$J,"ACRDOC",ACR,ACRJ))]"" D

 .D PAUSE^ACRFWARN

 .W @IOF

 .D PH

 Q

PH W !!?4,"ID.",?10,"CALL"

 W !?4,"NO."

 W ?10,"NO."

 W ?15,"REQUISITION NO."

 W ?35,"PURCHASE ORDER #"

 W ?55,"OBLIGATION DOC #"

 W !?4,"----- ---- ------------------"

 W ?35,"----------------"

 W ?55,"----------------"

 Q

CALLIM ;EP;TO DETERMINE IF CALL AMOUNT EXCEEDS BPA PER CALL LIMIT

 S ACRBPA=$P(^ACRDOC(ACRDOCDA,0),U,19)

 S ACRBPA=$P(^ACRDOC(ACRBPA,3),U,10)

 K ACRQUIT

 N ACR,ACRSUM

 S (ACR,ACRSUM)=0

 F  S ACR=$O(^ACRSS("J",ACRDOCDA,ACR)) Q:'ACR  I $D(^ACRSS(ACR,"DT")) S ACRSUM=ACRSUM+$P(^("DT"),U,4)

 I ACRSUM>ACRBPA S ACRQUIT=""

 Q

ACRFBPA   ;IHS/OIRM/DSD/THL,AEF - BPA MANAGEMENT; [ 10/27/2004   4:15 PM ]

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

 +2       ;;MANAGE VARIOUS ASPECTS OF BLANKET PURCHASE AGREEMENTS

CHOOSE    ;EP;

 +1        KILL ACRBPA,DIC,ACRDOC

 +2        SET DIC="^ACRDOC("

 +3        SET DIC(0)="AENMQZ"

 +4        SET DIC("A")="Which BLANKET PURCHASE AGREEMENT: "

 +5        SET DIC("S")="S ACRDOC0=$G(^ACRDOC(+Y,0)),ACRCDATE=$P($G(^(15)),U,11),ACRAPV=$G(^ACROBL(+Y,""APV""))"

 +6        SET DIC("S")=DIC("S")_" I '$PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P(ACRDOC0,U,15),$S($D(ACRBPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PASM):1,1:($D(^ACRDOC(+Y,6,""B"",DUZ))!$D(^ACRDOC(+Y,50,""B"",DUZ)))&$PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P(ACRDOC0,U,23)),$S(ACRCDATE&$D(ACRNEWOB):ACRCDATE>DT,1:1),$PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P(ACRDOC0,U,18)>0,$PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P(ACRDOC0,U,16),$PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P(ACRAPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">P">PA_source.html#xP">PA_source.html#xPA_source.html#xP">P">PA_source.html#xP">PV,U,8)=""A"""

 +7        SET D="T"

 +8        WRITE !

 +9        DO DIC^ACRFDIC

 +10       IF +Y'>0

               SET ACRQUIT=""

               QUIT 

 +11      ; ACR*2.1*14.03 IM13538

           IF $$LASTBPA^ACRFNEW1(+Y)

               Begin DoDot:1

 +12               WRITE *7,*7,!!?10,"ALL CALL NUMBERS FOR THIS BPA HAVE BEEN USED!"

 +13               DO PAUSE^ACRFWARN

 +14               SET ACRQUIT=""

               End DoDot:1

               QUIT 

 +15       SET ACRBPA=+Y

 +16       SET ACRBPA0=^ACRDOC(+Y,0)

 +17       SET ACRBPAPO=^ACRDOC(+Y,"PO")

 +18       SET ACRBPAPA=^ACRDOC(+Y,"PA")

 +19       SET ACRBPAV=$PIECE(ACRBPAPO,U,5)

 +20       SET ACRBPATX=$PIECE(ACRBPA0,U,4)

 +21       SET ACRBPAPS=$PIECE(ACRBPAPA,U,3)

 +22       SET ACRBPASP=$PIECE(ACRBPA0,U,16)

 +23       SET ACRBPATO=$PIECE(ACRBPAPO,U,6)

 +24       SET ACRBPAFO=$PIECE(ACRBPAPO,U,9)

 +25       SET ACRPONUM=$PIECE(ACRBPA0,U,2)

 +26       IF '$DATA(^ACRDOC(ACRBPA,3))!'$PIECE($GET(^ACRDOC(ACRBPA,3)),U,10)

               Begin DoDot:1

 +27               WRITE !!,*7,*7,"BPA Call Limit not set for this BPA.  Call Procurement for assistance."

 +28               DO PAUSE^ACRFWARN

 +29               SET ACRQUIT=""

               End DoDot:1

               QUIT 

 +30       KILL ACRBPA0,ACRBPAPO,ACRBPAPA

 +31       IF $DATA(ACRBPASM)

               QUIT 

 +32       WRITE !!,"Please hold for a moment while I determine the"

 +33       WRITE !,"total amount charged against this BPA to date."

 +34       DO BS

 +35       SET DIR(0)="DOA"

 +36       SET DIR("A")="ORDER DATE..........: "

 +37       SET DIR("B")="TODAY"

 +38       DO DIR^ACRFDIC

 +39       IF 'Y!$DATA(ACRQUIT)!$DATA(ACROUT)

               SET ACRQUIT=""

               QUIT 

 +40       SET (X1,ACROD)=Y

 +41       SET X2=45

 +42       DO C^%DTC

 +43       SET Y=X

 +44       XECUTE ^DD("DD")

 +45       SET DIR("B")=Y

 +46       SET DIR(0)="DOA"

 +47       SET DIR("A")="DATE REQUIRED.......: "

 +48       DO DIR^ACRFDIC

 +49       IF 'Y!$DATA(ACRQUIT)!$DATA(ACROUT)

               SET ACRQUIT=""

               QUIT 

 +50       SET ACRRQDD=Y

 +51       QUIT 

BPASUM    ;EP;TO SUMMARIZE TOTAL DOLLARS OBLIGATED AGAINST A BPA

 +1        DO ^XBKVAR

 +2        SET ACRBPASM=""

 +3        DO CHOOSE

 +4        IF '$DATA(ACRBPA)

               QUIT 

 +5        IF 'ACRBPA

               QUIT 

 +6        SET ACRDOCDA=ACRBPA

 +7        SET DIR(0)="YO"

 +8        SET DIR("A")="Print list of all Calls"

 +9        SET DIR("B")="NO"

 +10       SET DIR("?")="Enter 'Y' if you want a list of all calls against this BPA"

 +11       WRITE !

 +12       DO DIR^ACRFDIC

 +13       IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +14       SET ACRDOC=$SELECT(Y=1:"YES",1:"")

 +15       SET ACRRTN="BS^ACRFBPA"

 +16       SET ZTDESC="BPA SUMMARY"

 +17       DO ^ACRFZIS

 +18       QUIT 

BS        ;EP;TO PRINT BPA SUMMARY

 +1        NEW DATA

 +2        KILL ^TMP("ACRF",$JOB,"ACRDOC")

 +3        SET (ACRDOCDA,ACRREQ,ACROBL,ACRSPT,ACRJ)=0

 +4        KILL ACRBPASM

 +5        FOR 

               SET ACRDOCDA=$ORDER(^ACRDOC("BPA",ACRBPA,ACRDOCDA))

               IF 'ACRDOCDA

                   QUIT 

               IF $DATA(^ACRSS("J",ACRDOCDA))

                   Begin DoDot:1

 +6                    SET ACRJ=ACRJ+1

 +7                    SET ACRSPT=ACRSPT+$PIECE(^ACROBL(ACRDOCDA,"DT"),U,2)

 +8                    SET ACRSSDA=0

 +9                    FOR 

                           SET ACRSSDA=$ORDER(^ACRSS("J",ACRDOCDA,ACRSSDA))

                           IF 'ACRSSDA

                               QUIT 

                           IF $DATA(^ACRSS(ACRSSDA,0))

                               IF $DATA(^("DT"))

                                   SET ACRSSDT=^("DT")

                                   Begin DoDot:2

 +10                                   SET ACRREQ=ACRREQ+$PIECE(ACRSSDT,U,4)

 +11                                   SET ACROBL=ACROBL+$PIECE(ACRSSDT,U,9)

 +12                                   IF $DATA(ACRDOC)#2

                                           IF ACRDOC="YES"

                                               Begin DoDot:3

 +13                                               SET DATA=$GET(^ACRDOC(ACRDOCDA,0))

 +14                                               IF '$PIECE(DATA,U,2)

                                                       QUIT 

 +15                                               SET ^TMP("ACRF",$JOB,"ACRDOC"," "_$EXTRACT($PIECE(DATA,U,2),9,10),ACRJ)=$PIECE(DATA,U)_U_ACRDOCDA_U_$PIECE(DATA,U,2)

                                               End DoDot:3

                                   End DoDot:2

                   End DoDot:1

 +16       SET ACRBPAA=$PIECE(^ACRDOC(ACRBPA,0),U,18)

 +17       SET ACRDOC=$PIECE(^ACRDOC(ACRBPA,0),U,2)

 +18       IF $EXTRACT($GET(IOST),1,2)="C-"

               WRITE @IOF

 +19       WRITE !!?10,"TOTAL DOLLARS COMMITTED AND OBLIGATED AGAINST BPA: ",ACRDOC

 +20       WRITE !?10,"------------------------------------------------------------------"

 +21       WRITE !?10,"TOTAL SET ASIDE:"

 +22       WRITE ?27,"TOTAL COMMITTED:"

 +23       WRITE ?44,"TOTAL OBLIGATED:"

 +24       WRITE ?62,"TOTAL SPENT"

 +25       WRITE !?10,"---------------"

 +26       WRITE ?27,"---------------"

 +27       WRITE ?44,"---------------"

 +28       WRITE ?62,"--------------"

 +29       WRITE !?10,$JUSTIFY($FNUMBER(ACRBPAA,"P,",2),14)

 +30       WRITE ?27,$JUSTIFY($FNUMBER(ACRREQ,"P,",2),14)

 +31       WRITE ?44,$JUSTIFY($FNUMBER(ACROBL,"P,",2),14)

 +32       WRITE ?62,$JUSTIFY($FNUMBER(ACRSPT,"P,",2),14)

 +33       DO PAUSE^ACRFWARN

 +34       IF $DATA(^TMP("ACRF",$JOB,"ACRDOC"))

               Begin DoDot:1

 +35               DO PH

 +36               SET ACR=""

 +37               FOR 

                       SET ACR=$ORDER(^TMP("ACRF",$JOB,"ACRDOC",ACR))

                       IF ACR=""!$DATA(ACRQUIT)

                           QUIT 

                       Begin DoDot:2

 +38                       SET ACRJ=0

 +39                       FOR 

                               SET ACRJ=$ORDER(^TMP("ACRF",$JOB,"ACRDOC",ACR,ACRJ))

                               IF 'ACRJ!$DATA(ACRQUIT)

                                   QUIT 

                               Begin DoDot:3

 +40                               SET DATA=^TMP("ACRF",$JOB,"ACRDOC",ACR,ACRJ)

 +41                               SET ACRDOCDA=$PIECE(DATA,U,2)

 +42                               SET ACRDOCX=$ORDER(^ACRDHR("E",ACRDOCDA,0))

 +43                               IF ACRDOCX

                                       SET ACRDOCX=$PIECE($GET(^ACRDHR(ACRDOCX,0)),U)

 +44                               WRITE !?4,$PIECE(DATA,U,2)

 +45                               WRITE ?10,ACR

 +46                               WRITE ?15,$PIECE(DATA,U)

 +47                               WRITE ?35,$PIECE(DATA,U,3)

 +48                               IF ACRDOCX'=$PIECE(DATA,U,3)

                                       WRITE ?55,ACRDOCX

 +49                               DO P

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +50       DO PAUSE^ACRFWARN

 +51       WRITE @IOF

 +52       KILL ^TMP("ACRF",$JOB,"ACRDOC")

 +53       QUIT 

P         ;

 +1        IF IOSL-4<$Y

               IF $ORDER(^TMP("ACRF",$JOB,"ACRDOC",ACR,ACRJ))]""

                   Begin DoDot:1

 +2                    DO PAUSE^ACRFWARN

 +3                    WRITE @IOF

 +4                    DO PH

                   End DoDot:1

 +5        QUIT 

PH         WRITE !!?4,"ID.",?10,"CALL"

 +1        WRITE !?4,"NO."

 +2        WRITE ?10,"NO."

 +3        WRITE ?15,"REQUISITION NO."

 +4        WRITE ?35,"PURCHASE ORDER #"

 +5        WRITE ?55,"OBLIGATION DOC #"

 +6        WRITE !?4,"----- ---- ------------------"

 +7        WRITE ?35,"----------------"

 +8        WRITE ?55,"----------------"

 +9        QUIT 

CALLIM    ;EP;TO DETERMINE IF CALL AMOUNT EXCEEDS BPA PER CALL LIMIT

 +1        SET ACRBPA=$PIECE(^ACRDOC(ACRDOCDA,0),U,19)

 +2        SET ACRBPA=$PIECE(^ACRDOC(ACRBPA,3),U,10)

 +3        KILL ACRQUIT

 +4        NEW ACR,ACRSUM

 +5        SET (ACR,ACRSUM)=0

 +6        FOR 

               SET ACR=$ORDER(^ACRSS("J",ACRDOCDA,ACR))

               IF 'ACR

                   QUIT 

               IF $DATA(^ACRSS(ACR,"DT"))

                   SET ACRSUM=ACRSUM+$PIECE(^("DT"),U,4)

 +7        IF ACRSUM>ACRBPA

               SET ACRQUIT=""

 +8        QUIT