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
