ACRFPO1 ;IHS/OIRM/DSD/THL,AEF - PURCHASE ORDER PROCESSING; [ 1/31/2007 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**19,22**;NOV 05, 2001
;;CONTINUATION OF ACRFPO
ASSIGN ;EP;
K ACRAPDA
Q:$D(ACRQUIT)!$D(ACROUT)!(+Y<1)
S ACRREFX=116
S ACRREQST=""
D ACCEPT
I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q
W !
S DIR(0)="YO"
S DIR("A")="Print the Requisition now"
S DIR("B")="NO"
D DIR^ACRFDIC
Q:$D(ACROUT)
K ACRQUIT
I Y=1 D PR^ACRFEA42
K ACRREQST
Q:$D(ACROUT)
S DIR(0)="YO"
S DIR("A")="Is this procurement within our purchasing authority"
S DIR("B")="YES"
W !
D DIR^ACRFDIC
I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q
I ACRY'=1 D Q
.S DA=ACRDOCDA
.S DIE="^ACRDOC("
.S DR=".08T;.4T"
.D DIE^ACRFDIC
.S ACRPS=$P(^ACRDOC(ACRDOCDA,"PA"),U,3)
.;S ACRPS=$P($P($P(^VA(200,ACRPS,0),U),",",2)," ")_" "_$P($P(^(0),U),",") ;ACR*2.1*19.02 IM16848
.S ACRPS=$$NAME3^ACRFUTL1(ACRPS) ;ACR*2.1*19.02 IM16848
.W !!,"Document ",ACRDOC," transferred to ",ACRPS
.W !,"for assignment and processing."
.W !
.D PAUSE^ACRFWARN
S DIR(0)="SO^1:Purchase Order;2:Award/Contract (SF 26);3:Solicitation, Offer and Award (SF 33);4:Solicitation/Contract/Order for Commercial Items (SF 1449);5:Tribal Contract"
S DIR("A")="Type of procurement action"
S DIR("?")="Indicate the type of procurement action to be taken."
W !
I 0 D DIR^ACRFDIC
I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q
S DA=ACRDOCDA
S DIE="^ACRDOC("
S DR=".24///"_$S(ACRY=1:"@",1:(ACRY-1))_";.13///"_$S(ACRY=1:"103",ACRY=5:"326",1:"349")
S DR=".24///@;.13///103"
D DIE^ACRFDIC
W !!,"Assign ",ACRDOC," to:"
S ACRPA=+$G(^ACRDOC(ACRDOCDA,"PA"))
S DA=ACRDOCDA
S DIE="^ACRDOC("
S DR=".2T;103960T;20T"
D DIE^ACRFDIC
I +$G(^ACRDOC(ACRDOCDA,"PA")),+^("PA")'=ACRPA D
.D NOW^%DTC
.S X=%
.S DIC(0)="L"
.S DIC="^ACRDOC("_ACRDOCDA_",11,"
.S DA(1)=ACRDOCDA
.S DIC("DR")=".02////"_ACRPA_";.03////"_DUZ
.S:'$D(@(DIC_"0)")) ^ACRDOC(ACRDOCDA,11,0)="^9002196.0111D"
.D FILE^ACRFDIC
Q
ACCEPT ;EP;
S DIR(0)="SO^1:Accept Requisition;2:Send Message to Requestor;3:Return Requisition for Resubmission"
S DIR("B")="Accept Requisition"
W !
D DIR^ACRFDIC
I ACRY=2 D
.S ACRAPDAS=""
.D XMY^ACRFXMY
.S (ACRY,Y)=2
I ACRY=3 D Q
.D REACT^ACRFEA4
.I ACRY=1 D
..S ACRAPDAS="R"
..D XMY^ACRFXMY
..W !,ACRDOC," resubmitted for change/clarification."
..D PAUSE^ACRFWARN
..S ACRQUIT="",Y=-1
..I $P(^ACRDOC(ACRDOCDA,0),U,4)=35,$P(^(0),U,7),$P(^(0),U,7)'=35 D
...S DA=ACRDOCDA
...S DIE="^ACRDOC("
...S DR=".04////"_$P(^ACRDOC(ACRDOCDA,0),U,7)
...D DIE^ACRFDIC
Q
PRINT ;EP;TO PRINT PURCHASE ORDER
F D P1 Q:$D(ACRQUIT)!$D(ACROUT)
K ACRQUIT,ACRPPO
Q
P1 I '$D(ACRREQST) D
.S DIC("S")="S ACRAPV=$G(^ACROBL(+Y,""APV"")),ACRREFZ=$P(^ACRDOC(+Y,0),U,13),ACRREFZ=$P($G(^AUTTDOCR(+ACRREFZ,0)),U)"
.S DIC("S")=DIC("S")_" I ""^103^210^349^326^""[(U_ACRREFZ_U)!(ACRREFZ=116&($P(^ACRDOC(+Y,0),U,4)=35)!($P(^(0),U,12))),$E(ACRAPV)=""A"""
D LOOKUP^ACRFPO3
K ACRREFZ,ACRAPV
Q:$D(ACRQUIT)!$D(ACROUT)
D PSC:$D(ACRPPO)
Q:$D(ACRQUIT)!$D(ACROUT)
D PRINT^ACRFSHIP:ACRREFX'=349
I '$D(ACRRR)#2,'$P(ACRDOC0,U,19) D Q:$D(ACROUT)
.D ^ACRFSSPO
.;Q:ACRPOTOT<2500.999 ;ACR*2.1*22.06 IM23064
.Q:ACRPOTOT<3000.999 ;ACR*2.1*22.06 IM23064
.N X
.S X=$P($G(^ACRDOC(ACRDOCDA,13)),U,5,6)
.Q:$L(X)=1
.S DIR(0)="YO"
.S DIR("A")="Include Cost Comparison"
.S DIR("B")="NO"
.W !
.D DIR^ACRFDIC
.S:Y=1 ACRCOST=""
.Q:$D(ACROUT)
P11 ;EP;FOR RECEIVING REPORT PRINT
N ACRPAGE ;ACR*2.1*22.01 IM22636
I $D(ACRRR)#2!($D(ACRIV)#2) D Q:$D(ACRQUIT)!$D(ACROUT)!'$G(ACRRRNO)
.D RRNO^ACRFRRPT
.Q:$D(ACRQUIT)!$D(ACROUT)!'$D(ACRRRNO)
.Q:'ACRRRNO
.S (ACRREF,ACRREFX)=499
I $D(ACRFEDS) D
.S (ACRREF,ACRREFX)=210
.S:$P($G(^ACRDOC(ACRDOCDA,3)),U,17)=1 ACR3542=""
D TSKVAR^ACRFPRNT
S ACRRTN="^ACRFQ"
D ^ACRFZIS
K ACRQUIT,ACR3542,ACRPSC,ACRORIGF,ACRADJST
Q
EDIT ;EP;
S ACRENTRY=$T(@ACRENTRY^ACRFCTL1)
S ACRPO=""
K ACRPOA
D SET^ACRFEA
D ^ACRFEA4
K ACRPRCS
Q
AMEND ;EP;
S DIC("S")="S ACRREF=$P(^ACRDOC(+Y,0),U,13),ACRREF=$P(^AUTTDOCR(ACRREF,0),U) I ""^116^103^349^326^210^148^""[(U_ACRREF_U),$D(^ACROBL(+Y,""APV"")),$P(^(""APV""),U,8)=""A"""
D LOOKUP^ACRFPO3
Q:$D(ACRQUIT)!$D(ACROUT)
D NOW^%DTC
S X=DUZ
S DA(1)=ACRDOCDA
S DIC="^ACRDOC("_DA(1)_",7,"
S DIC(0)="L"
S DIC("DR")=".02///"_%
S:'$D(^ACRDOC(DA(1),7,0)) ^ACRDOC(DA(1),7,0)="^9002196.07"
D FILE^ACRFDIC
N ACRENTRY,ACRPO
S ACRENTRY="PO",ACRPO=""
D ^ACRFEA41:'$D(ACRCANCL)
I $D(ACRCANCL) S ACRMCODE=4 D EN2^ACRFDEL
Q
FEDSTRIP ;EP;TO PRINT FEDSTRIP ORDER
S ACRFEDS=""
D PRINT
Q
ACRCANCL ;EP;TO SELECT APPROVED PURCHASE ORDER FOR CANCELLATION
K ACRREQST
N ACRPO,ACRENTRY,ACRCANCL
S ACRENTRY="PO"
S ACRCANCL=""
S ACRPO=""
D AMEND
K ACRPRT
Q
SPENT ;EP;TO ADJUST OBLIGATION WITH THE ACTUAL EXPENDITURE
F D S1 Q:$D(ACRQUIT)
K ACRQUIT
Q
S1 D LOOKUP^ACRFPO3
Q:$D(ACRQUIT)
S DA=ACRDOCDA
S DIE="^ACRDOC("
S DR="103200.1T;103200.2T"
D DIE^ACRFDIC
S DA=ACRDOCDA
S DIE="^ACROBL("
S DR="2FINAL PAYMENT AMOUNT"
D DIE^ACRFDIC
Q
MOD ;EP;PURCHASE AGENT OPTIONS
W @IOF
W !?20,"Purchasing Agent Options"
K ACRPOA
S ACRPO=""
S DIR(0)="SO^1:Process Signed Requisition;2:Create Modification;3:Edit Pending Modification;4:Quit"
D DIR^ACRFDIC
I $D(ACROUT)!$D(ACRQUIT)!(123'[$G(Y)) S ACRQUIT="" Q
I Y=1 D EN^ACRFPO S Y=1
I Y=2 D M1 S Y=2
I Y=3 D M2 S Y=3
K ACRQUIT,ACRPPO,ACRPRT
Q
M1 ;
N ACRPO,ACRENTRY
S ACRENTRY="OBLAMT"
S ACRENTRY=$T(@ACRENTRY^ACRFCTL1)
S ACRZY=""
D SET^ACRFEA
D A1^ACRFNEWD
D A1^ACRFEA1:'$D(ACRQUIT)&$G(ACRAMEND)
Q
M2 ;
S DIC="^ACRDOC("
S DIC(0)="AEMQZ"
S DIC("A")="Edit Which Modification: "
S D="B^C^G^J"
S DIC("S")="S ACRXX=^ACRDOC(+Y,0),ACRAPV=$G(^ACROBL(+Y,""APV"")),ACRREF=$P(ACRXX,U,13),ACRREF=$P(^AUTTDOCR(ACRREF,0),U) I ""^116^204^210^""[(U_ACRREF_U),$P(ACRXX,U,15),$P(ACRAPV,U)="""""
W !
D MIX^ACRFDIC
S:+Y<1 ACRQUIT=""
Q:$D(ACRQUIT)!$D(ACROUT)
S ACRDOCDA=+Y
D SETDOC^ACRFEA1
D ^ACRFEA41
Q
PSC ;EP;DETERMINE WHICH PO TO PRINT
K ACRPSC,ACRORIGF
S Y=$P(^ACRDOC(ACRDOCDA,0),U,24)+1
I +Y<1 K ACRPSC S ACRQUIT="" Q
I +Y=1 S ACRPSC="347^50"
I +Y=2 S ACRPSC="26^32"
I +Y=3 S ACRPSC="33^33"
I +Y=4 S ACRPSC="1449^32"
I +Y=5 S ACRPSC="326^50" Q
I Y'=1 D PSC1 Q
;PRINT ON BLANK PAPER OR PRE-PRINTED FORM
S DIR(0)="SO^1:Print on blank paper;2:Print on Pre-printed form"
S DIR("A")="Which print format"
S DIR("B")=1
W !
D DIR^ACRFDIC
Q:+Y'=2
PSC1 S ACRORIGF=""
S DIR(0)="NO^0:2"
S DIR("A")="Adjust TOP OF PAGE by (number of lines)"
S DIR("B")=0
W !
D DIR^ACRFDIC
I "012"'[Y S ACRQUIT="" Q
S ACRADJST=Y
Q
ACRFPO1 ;IHS/OIRM/DSD/THL,AEF - PURCHASE ORDER PROCESSING; [ 1/31/2007 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19,22**;NOV 05, 2001
+2 ;;CONTINUATION OF ACRFPO
ASSIGN ;EP;
+1 KILL ACRAPDA
+2 IF $DATA(ACRQUIT)!$DATA(ACROUT)!(+Y<1)
QUIT
+3 SET ACRREFX=116
+4 SET ACRREQST=""
+5 DO ACCEPT
+6 IF $DATA(ACRQUIT)!$DATA(ACROUT)
KILL ACRQUIT
QUIT
+7 WRITE !
+8 SET DIR(0)="YO"
+9 SET DIR("A")="Print the Requisition now"
+10 SET DIR("B")="NO"
+11 DO DIR^ACRFDIC
+12 IF $DATA(ACROUT)
QUIT
+13 KILL ACRQUIT
+14 IF Y=1
DO PR^ACRFEA42
+15 KILL ACRREQST
+16 IF $DATA(ACROUT)
QUIT
+17 SET DIR(0)="YO"
+18 SET DIR("A")="Is this procurement within our purchasing authority"
+19 SET DIR("B")="YES"
+20 WRITE !
+21 DO DIR^ACRFDIC
+22 IF $DATA(ACRQUIT)!$DATA(ACROUT)
KILL ACRQUIT
QUIT
+23 IF ACRY'=1
Begin DoDot:1
+24 SET DA=ACRDOCDA
+25 SET DIE="^ACRDOC("
+26 SET DR=".08T;.4T"
+27 DO DIE^ACRFDIC
+28 SET ACRPS=$PIECE(^ACRDOC(ACRDOCDA,"PA"),U,3)
+29 ;S ACRPS=$P($P($P(^VA(200,ACRPS,0),U),",",2)," ")_" "_$P($P(^(0),U),",") ;ACR*2.1*19.02 IM16848
+30 ;ACR*2.1*19.02 IM16848
SET ACRPS=$$NAME3^ACRFUTL1(ACRPS)
+31 WRITE !!,"Document ",ACRDOC," transferred to ",ACRPS
+32 WRITE !,"for assignment and processing."
+33 WRITE !
+34 DO PAUSE^ACRFWARN
End DoDot:1
QUIT
+35 SET DIR(0)="SO^1:Purchase Order;2:Award/Contract (SF 26);3:Solicitation, Offer and Award (SF 33);4:Solicitation/Contract/Order for Commercial Items (SF 1449);5:Tribal Contract"
+36 SET DIR("A")="Type of procurement action"
+37 SET DIR("?")="Indicate the type of procurement action to be taken."
+38 WRITE !
+39 IF 0
DO DIR^ACRFDIC
+40 IF $DATA(ACRQUIT)!$DATA(ACROUT)
KILL ACRQUIT
QUIT
+41 SET DA=ACRDOCDA
+42 SET DIE="^ACRDOC("
+43 SET DR=".24///"_$SELECT(ACRY=1:"@",1:(ACRY-1))_";.13///"_$SELECT(ACRY=1:"103",ACRY=5:"326",1:"349")
+44 SET DR=".24///@;.13///103"
+45 DO DIE^ACRFDIC
+46 WRITE !!,"Assign ",ACRDOC," to:"
+47 SET ACRPA=+$GET(^ACRDOC(ACRDOCDA,"PA"))
+48 SET DA=ACRDOCDA
+49 SET DIE="^ACRDOC("
+50 SET DR=".2T;103960T;20T"
+51 DO DIE^ACRFDIC
+52 IF +$GET(^ACRDOC(ACRDOCDA,"PA"))
IF +^("PA")'=ACRPA
Begin DoDot:1
+53 DO NOW^%DTC
+54 SET X=%
+55 SET DIC(0)="L"
+56 SET DIC="^ACRDOC("_ACRDOCDA_",11,"
+57 SET DA(1)=ACRDOCDA
+58 SET DIC("DR")=".02////"_ACRPA_";.03////"_DUZ
+59 IF '$DATA(@(DIC_"0)"))
SET ^ACRDOC(ACRDOCDA,11,0)="^9002196.0111D"
+60 DO FILE^ACRFDIC
End DoDot:1
+61 QUIT
ACCEPT ;EP;
+1 SET DIR(0)="SO^1:Accept Requisition;2:Send Message to Requestor;3:Return Requisition for Resubmission"
+2 SET DIR("B")="Accept Requisition"
+3 WRITE !
+4 DO DIR^ACRFDIC
+5 IF ACRY=2
Begin DoDot:1
+6 SET ACRAPDAS=""
+7 DO XMY^ACRFXMY
+8 SET (ACRY,Y)=2
End DoDot:1
+9 IF ACRY=3
Begin DoDot:1
+10 DO REACT^ACRFEA4
+11 IF ACRY=1
Begin DoDot:2
+12 SET ACRAPDAS="R"
+13 DO XMY^ACRFXMY
+14 WRITE !,ACRDOC," resubmitted for change/clarification."
+15 DO PAUSE^ACRFWARN
+16 SET ACRQUIT=""
SET Y=-1
+17 IF $PIECE(^ACRDOC(ACRDOCDA,0),U,4)=35
IF $PIECE(^(0),U,7)
IF $PIECE(^(0),U,7)'=35
Begin DoDot:3
+18 SET DA=ACRDOCDA
+19 SET DIE="^ACRDOC("
+20 SET DR=".04////"_$PIECE(^ACRDOC(ACRDOCDA,0),U,7)
+21 DO DIE^ACRFDIC
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+22 QUIT
PRINT ;EP;TO PRINT PURCHASE ORDER
+1 FOR
DO P1
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+2 KILL ACRQUIT,ACRPPO
+3 QUIT
P1 IF '$DATA(ACRREQST)
Begin DoDot:1
+1 SET DIC("S")="S ACRAPV=$G(^ACROBL(+Y,""APV"")),ACRREFZ=$P(^ACRDOC(+Y,0),U,13),ACRREFZ=$P($G(^AUTTDOCR(+ACRREFZ,0)),U)"
+2 SET DIC("S")=DIC("S")_" I ""^103^210^349^326^""[(U_ACRREFZ_U)!(ACRREFZ=116&($P(^ACRDOC(+Y,0),U,4)=35)!($P(^(0),U,12))),$E(ACRAPV)=""A"""
End DoDot:1
+3 DO LOOKUP^ACRFPO3
+4 KILL ACRREFZ,ACRAPV
+5 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+6 IF $DATA(ACRPPO)
DO PSC
+7 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+8 IF ACRREFX'=349
DO PRINT^ACRFSHIP
+9 IF '$DATA(ACRRR)#2
IF '$PIECE(ACRDOC0,U,19)
Begin DoDot:1
+10 DO ^ACRFSSPO
+11 ;Q:ACRPOTOT<2500.999 ;ACR*2.1*22.06 IM23064
+12 ;ACR*2.1*22.06 IM23064
IF ACRPOTOT<3000.999
QUIT
+13 NEW X
+14 SET X=$PIECE($GET(^ACRDOC(ACRDOCDA,13)),U,5,6)
+15 IF $LENGTH(X)=1
QUIT
+16 SET DIR(0)="YO"
+17 SET DIR("A")="Include Cost Comparison"
+18 SET DIR("B")="NO"
+19 WRITE !
+20 DO DIR^ACRFDIC
+21 IF Y=1
SET ACRCOST=""
+22 IF $DATA(ACROUT)
QUIT
End DoDot:1
IF $DATA(ACROUT)
QUIT
P11 ;EP;FOR RECEIVING REPORT PRINT
+1 ;ACR*2.1*22.01 IM22636
NEW ACRPAGE
+2 IF $DATA(ACRRR)#2!($DATA(ACRIV)#2)
Begin DoDot:1
+3 DO RRNO^ACRFRRPT
+4 IF $DATA(ACRQUIT)!$DATA(ACROUT)!'$DATA(ACRRRNO)
QUIT
+5 IF 'ACRRRNO
QUIT
+6 SET (ACRREF,ACRREFX)=499
End DoDot:1
IF $DATA(ACRQUIT)!$DATA(ACROUT)!'$GET(ACRRRNO)
QUIT
+7 IF $DATA(ACRFEDS)
Begin DoDot:1
+8 SET (ACRREF,ACRREFX)=210
+9 IF $PIECE($GET(^ACRDOC(ACRDOCDA,3)),U,17)=1
SET ACR3542=""
End DoDot:1
+10 DO TSKVAR^ACRFPRNT
+11 SET ACRRTN="^ACRFQ"
+12 DO ^ACRFZIS
+13 KILL ACRQUIT,ACR3542,ACRPSC,ACRORIGF,ACRADJST
+14 QUIT
EDIT ;EP;
+1 SET ACRENTRY=$TEXT(@ACRENTRY^ACRFCTL1)
+2 SET ACRPO=""
+3 KILL ACRPOA
+4 DO SET^ACRFEA
+5 DO ^ACRFEA4
+6 KILL ACRPRCS
+7 QUIT
AMEND ;EP;
+1 SET DIC("S")="S ACRREF=$P(^ACRDOC(+Y,0),U,13),ACRREF=$P(^AUTTDOCR(ACRREF,0),U) I ""^116^103^349^326^210^148^""[(U_ACRREF_U),$D(^ACROBL(+Y,""APV"")),$P(^(""APV""),U,8)=""A"""
+2 DO LOOKUP^ACRFPO3
+3 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+4 DO NOW^%DTC
+5 SET X=DUZ
+6 SET DA(1)=ACRDOCDA
+7 SET DIC="^ACRDOC("_DA(1)_",7,"
+8 SET DIC(0)="L"
+9 SET DIC("DR")=".02///"_%
+10 IF '$DATA(^ACRDOC(DA(1),7,0))
SET ^ACRDOC(DA(1),7,0)="^9002196.07"
+11 DO FILE^ACRFDIC
+12 NEW ACRENTRY,ACRPO
+13 SET ACRENTRY="PO"
SET ACRPO=""
+14 IF '$DATA(ACRCANCL)
DO ^ACRFEA41
+15 IF $DATA(ACRCANCL)
SET ACRMCODE=4
DO EN2^ACRFDEL
+16 QUIT
FEDSTRIP ;EP;TO PRINT FEDSTRIP ORDER
+1 SET ACRFEDS=""
+2 DO PRINT
+3 QUIT
ACRCANCL ;EP;TO SELECT APPROVED PURCHASE ORDER FOR CANCELLATION
+1 KILL ACRREQST
+2 NEW ACRPO,ACRENTRY,ACRCANCL
+3 SET ACRENTRY="PO"
+4 SET ACRCANCL=""
+5 SET ACRPO=""
+6 DO AMEND
+7 KILL ACRPRT
+8 QUIT
SPENT ;EP;TO ADJUST OBLIGATION WITH THE ACTUAL EXPENDITURE
+1 FOR
DO S1
IF $DATA(ACRQUIT)
QUIT
+2 KILL ACRQUIT
+3 QUIT
S1 DO LOOKUP^ACRFPO3
+1 IF $DATA(ACRQUIT)
QUIT
+2 SET DA=ACRDOCDA
+3 SET DIE="^ACRDOC("
+4 SET DR="103200.1T;103200.2T"
+5 DO DIE^ACRFDIC
+6 SET DA=ACRDOCDA
+7 SET DIE="^ACROBL("
+8 SET DR="2FINAL PAYMENT AMOUNT"
+9 DO DIE^ACRFDIC
+10 QUIT
MOD ;EP;PURCHASE AGENT OPTIONS
+1 WRITE @IOF
+2 WRITE !?20,"Purchasing Agent Options"
+3 KILL ACRPOA
+4 SET ACRPO=""
+5 SET DIR(0)="SO^1:Process Signed Requisition;2:Create Modification;3:Edit Pending Modification;4:Quit"
+6 DO DIR^ACRFDIC
+7 IF $DATA(ACROUT)!$DATA(ACRQUIT)!(123'[$GET(Y))
SET ACRQUIT=""
QUIT
+8 IF Y=1
DO EN^ACRFPO
SET Y=1
+9 IF Y=2
DO M1
SET Y=2
+10 IF Y=3
DO M2
SET Y=3
+11 KILL ACRQUIT,ACRPPO,ACRPRT
+12 QUIT
M1 ;
+1 NEW ACRPO,ACRENTRY
+2 SET ACRENTRY="OBLAMT"
+3 SET ACRENTRY=$TEXT(@ACRENTRY^ACRFCTL1)
+4 SET ACRZY=""
+5 DO SET^ACRFEA
+6 DO A1^ACRFNEWD
+7 IF '$DATA(ACRQUIT)&$GET(ACRAMEND)
DO A1^ACRFEA1
+8 QUIT
M2 ;
+1 SET DIC="^ACRDOC("
+2 SET DIC(0)="AEMQZ"
+3 SET DIC("A")="Edit Which Modification: "
+4 SET D="B^C^G^J"
+5 SET DIC("S")="S ACRXX=^ACRDOC(+Y,0),ACRAPV=$G(^ACROBL(+Y,""APV"")),ACRREF=$P(ACRXX,U,13),ACRREF=$P(^AUTTDOCR(ACRREF,0),U) I ""^116^204^210^""[(U_ACRREF_U),$P(ACRXX,U,15),$P(ACRAPV,U)="""""
+6 WRITE !
+7 DO MIX^ACRFDIC
+8 IF +Y<1
SET ACRQUIT=""
+9 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+10 SET ACRDOCDA=+Y
+11 DO SETDOC^ACRFEA1
+12 DO ^ACRFEA41
+13 QUIT
PSC ;EP;DETERMINE WHICH PO TO PRINT
+1 KILL ACRPSC,ACRORIGF
+2 SET Y=$PIECE(^ACRDOC(ACRDOCDA,0),U,24)+1
+3 IF +Y<1
KILL ACRPSC
SET ACRQUIT=""
QUIT
+4 IF +Y=1
SET ACRPSC="347^50"
+5 IF +Y=2
SET ACRPSC="26^32"
+6 IF +Y=3
SET ACRPSC="33^33"
+7 IF +Y=4
SET ACRPSC="1449^32"
+8 IF +Y=5
SET ACRPSC="326^50"
QUIT
+9 IF Y'=1
DO PSC1
QUIT
+10 ;PRINT ON BLANK PAPER OR PRE-PRINTED FORM
+11 SET DIR(0)="SO^1:Print on blank paper;2:Print on Pre-printed form"
+12 SET DIR("A")="Which print format"
+13 SET DIR("B")=1
+14 WRITE !
+15 DO DIR^ACRFDIC
+16 IF +Y'=2
QUIT
PSC1 SET ACRORIGF=""
+1 SET DIR(0)="NO^0:2"
+2 SET DIR("A")="Adjust TOP OF PAGE by (number of lines)"
+3 SET DIR("B")=0
+4 WRITE !
+5 DO DIR^ACRFDIC
+6 IF "012"'[Y
SET ACRQUIT=""
QUIT
+7 SET ACRADJST=Y
+8 QUIT
