ACRFPAPV ;IHS/OIRM/DSD/THL,AEF - PRINT APPROVALS ON REQUESTS; [ 10/27/2006 4:15 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**14,19,21**;NOV 05, 2001
;;ROUTINE TO PRINT APPROVALS AND TO DISPLAY STATUS OF A REQUEST
EN ;EP;
Q:$D(ACROUT)
I "^116^204^103^349^326^210^"[(U_ACRREFX_U),'$D(^ACRSS("J",ACRDOCDA)) D CONSOL^ACRFPAP1 Q
N ACRX,ACRY,ACRJ,D0
S:$D(ACRDOCDA) D0=ACRDOCDA
D EN1
I $E(IOST,1,2)="C-",'$D(ACRREF)!$D(ACRCOMP)!$D(ACRPRT)!$D(ACRPO)!$D(ACRREV)!$D(ACRCSI) D PAUSE^ACRFWARN
EXIT K ACRZ,Y,ACRCT,ACRSTATS
Q
EN1 N ACRPHEAD
S (ACRPHEAD,ACRX)=0
I $P(^ACRDOC(ACRDOCDA,0),U,19) N ACRREFX S ACRREFX=116
S ACRREFDA=$O(^AUTTDOCR("B",$S(ACRREF'=210:ACRREFX,1:ACRREF),0))
I ACRREF=210,$D(ACRREQST)!(ACRREFX=116) D
.S ACRREFDA=$O(^AUTTDOCR("B",116,0))
.S ACRREFX=116
I '$D(ACRORIGF) D
.F S ACRX=$O(^ACRAPVS("AB",D0,ACRX)) Q:'ACRX I $P(^ACRAPVS(ACRX,0),U,6)=ACRREFDA!($P($G(ACRDOC0),U,4)=35) S ACRPHEAD=ACRPHEAD+1
.D PHEAD^ACRFSS12:'$D(ACRORIGF)
I '$D(ACRPPO),ACRREFX'=148,'$D(ACRCSI),$E($G(IOST),1,2)="C-",'$D(ACRREV) W @IOF
W !
D:'$D(ACRPSC) B1
W:ACRREF'=148&'$D(ACRPSC) "------------------------------------------------------------------------------"
W:ACRREF=148 "---------------------- SECTION D - CLEARANCE ACTION ------------------------"
D:'$D(ACRPSC) B1
S ACRREFDA=$O(^AUTTDOCR("B",$S(ACRREF'=210:ACRREFX,1:ACRREF),0))
I ACRREF=210,$D(ACRREQST)!(ACRREFX=116) D
.S ACRREFDA=$O(^AUTTDOCR("B",116,0))
.S ACRREFX=116
I "^103^349^326^210^"[(U_ACRREFX_U),'$D(ACRREV),'$D(ACRPRT),$D(^ACROBL(ACRDOCDA,"APV")),$P(^("APV"),U,6) D
.W !,$S($P(^ACROBL(ACRDOCDA,"APV"),U,6)=1:"FINAL",1:"PARTIAL")," RECEIVING REPORT COMPLETED" Q
S (ACRX,ACRJ)=0
F S ACRX=$O(^ACRAPVS("AB",D0,ACRX)) Q:'ACRX I $P(^ACRAPVS(ACRX,0),U,6)=ACRREFDA!($P($G(ACRDOC0),U,4)=35) D
.S ACRAP0=$G(^ACRAPVS(ACRX,0))
.S ACRAPDT=$G(^ACRAPVS(ACRX,"DT"))
.Q:$P(ACRAPDT,U,8)>DT
.I ACRAP0=""&(ACRAPDT="") D Q
..S DA=ACRX
..S DIK="^ACRAPVS("
..D DIK^ACRFDIC
.D EN11
I ACRJ=0 W ! D Q
.N ACRSTAT ;ACR*2.1*21.05 IM22502
.S ACRSTAT=$E(ACROBLAP) ;ACR*2.1*21.05 IM22502
.I ACRREFX'=103,ACRREFX'=349,ACRREFX'=326,ACRREFX'=600,ACRREFX'=210 D
..W "THIS DOCUMENT HAS "
..;Begin old code ACR*2.1*21.05 IM22502
..;W $S($E(ACROBLAP)'="D":"NOT BEEN SUBMITTED FOR APPROVAL.",1:"BEEN DISAPPROVED.")
..;Begin new code ACR*2.1*21
..I ACRSTAT="D" W "BEEN DISAPPROVED." Q
..I ACRSTAT="C" W "BEEN CANCELLED." Q
..W "NOT BEEN SUBMITTED FOR APPROVAL."
..;End new code
.I ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)!(ACRREFX=210) D
..;I $E(ACROBLAP)="D" W $S(ACRDOC0["CANCELLED":"CANCELLED",1:"DISAPPROVED") Q ;ACR*2.1*21.05 IM22502
..I $E(ACROBLAP)="D"!($E(ACROBLAP)="C") W $S(ACRDOC0["CANCELLED":"CANCELLED",1:"DISAPPROVED") Q ;ACR*2.1*21.05 IM22502
..I $P(ACRDOC0,U,4)=35,$P(ACROBLAP,U,8)="A" W "CREDIT CARD PURCHASE APPROVED AND COMPLETED" Q
..W "BEING PROCESSED IN PROCURMENT BY: "
..N ACRPA
..S ACRPA=$P($G(^ACRDOC(D0,"PA")),U)
..I 'ACRPA W "PURCHASING AGENT NOT SELECTED."
..;E S ACRPA=$P(^VA(200,ACRPA,0),U),ACRPA=$P($P(ACRPA,",",2)," ")_" "_$P(ACRPA,",") ;ACR*2.1*19.02 IM16848
..E S ACRPA=$$NAME2^ACRFUTL1(ACRPA),ACRPA=$P($P(ACRPA,",",2)," ")_" "_$P(ACRPA,",") ;ACR*2.1*19.02 IM16848
..W:ACRPA]"" ACRPA
..I $D(^ACRDOC(ACRDOCDA,13)) D
...N ACR13
...S ACR13=$P(^ACRDOC(ACRDOCDA,13),U,4)
...W:ACR13]"" ?$X+2,"PO DUE BY: ",$E(ACR13,4,5),"/",$E(ACR13,6,7)
..D PDOCSTAT^ACRFEA42
.;Begin old code ACR*2.1*21.05 IM22502
.;I ACRREFX=600 D
.;.I $P(^ACROBL(ACRDOCDA,"APV"),U)="D" D Q
.;..W "TRAVEL VOUCHER WAS DISAPPROVED."
.;.W "TRAVEL VOUCHER BEING PREPARED."
.;Begin new code ACR*2.1*21.05 IM22502
.I ACRREFX=600 D
..I $P(^ACROBL(ACRDOCDA,"APV"),U)="D"!($P(^ACROBL(ACRDOCDA,"APV"),U)="C") D Q
...W "TRAVEL VOUCHER WAS "
...W $S(ACRDOC0["CANCELLED":"CANCELLED",1:"DISAPPROVED")
..W "TRAVEL VOUCHER BEING PREPARED."
.;End new code
I ACRREFX'=103,ACRREFX'=349,ACRREFX'=326 D
.W !,"| APPROVAL FOR DOCUMENT: ",ACRDOC
.W " ",$$EXPDN^ACRFUTL(ACRDOCDA) ;ACR*2.1*14.01 IM12272
.W ?79,"|"
S ACRX=0
F S ACRX=$O(ACRX(ACRX)) Q:'ACRX D EN12
D TAIL^ACRFPAP1:$E($G(IOST),1,2)="P-"&'$D(ACRPSC)
Q
EN11 I $P(ACRDOC0,U,4)=35,$P(ACRAP0,U,3)=1,$P(ACRAP0,U,4)=1 S $P(ACRAP0,U,4)=999
S ACRX($P(ACRAP0,U,4),$P(ACRAP0,U,3),ACRX)=""
S ACRDOC=$S($P(ACRDOC0,U,2)]""&($P(ACRDOC0,U,2)'=$P(ACRDOC0,U))&'$D(ACRREQST):$P(ACRDOC0,U,2)_" ("_$P(ACRDOC0,U)_")",1:$P(ACRDOC0,U))
S ACRJ=ACRJ+1
Q
EN12 S ACRY=0
F S ACRY=$O(ACRX(ACRX,ACRY)) Q:'ACRY D
.S ACRZ=$O(ACRX(ACRX,ACRY,0))
.S ACRCT=$P(^ACRAPVS(ACRZ,0),U,3)
.S ACRDT=$G(^ACRAPVS(ACRZ,"DT"))
.S ACRSTATS=$P(ACRDT,U)
.S ACRFINAL=$P(ACRDT,U,5)
.S ACRUS=$S($P(ACRDT,U,6)]"":$P(ACRDT,U,6),1:$P(ACRDT,U,2))
.S ACRUSO=$P(ACRDT,U,2)
.S Y=$P(ACRDT,U,4)
X:Y]"" ^DD("DD")
S:$D(ACRORIGF) ACRAP=Y
D EN2
Q
EN2 I 'ACRCT S ACRCT="NOT STATED"
I ACRCT=1,ACRSTATS="" D
.W !
.D B
.W $S($D(ACR3542):"9A. ",'$D(ACRPSC):"22. ",1:" "),"(DOCUMENT PENDING CONTRACT/ORDER OFFICER SIGNATURE)"
.W ?79
.D B
I ACRCT,'$D(^ACRAPVT(ACRCT,0)) S ACRCT="NOT STATED"
I ACRCT,$D(^ACRAPVT(ACRCT,0)) D
.D EN^ACRFPAP1
.S ACRCT=$P(^ACRAPVT(ACRCT,0),U)
I ACRX=99 S ACRCT="RECERTIFY FUNDS"
I ACRUS,$D(^VA(200,ACRUS,0)) D
.;S ACRUS=$E($P(^VA(200,ACRUS,0),U),1,24) ;ACR*2.1*19.02 IM16848
.S ACRUS=$E($$NAME3^ACRFUTL1(ACRUS),1,24) ;ACR*2.1*19.02 IM16848
.S ACRUS=$P(ACRUS,",",2)_" "_$P(ACRUS,",")
.I ACRUSO'=ACRUS,$D(^VA(200,ACRUSO,0)) D I 1
..;S ACRUSO=$E($P(^VA(200,ACRUSO,0),U),1,24) ;ACR*2.1*19.02 IM16848
..S ACRUSO=$E($$NAME3^ACRFUTL1(ACRUSO),1,24) ;ACR*2.1*19.02 IM16848
..S ACRUSO=$P(ACRUSO,",",2)_" "_$P(ACRUSO,",")
E S ACRUS="NOT STATED"
S ACRCT=$E($P($P(ACRCT,",",2)," ")_" "_$P(ACRCT,","),1,21)
I ACRREFX=103!(ACRREFX=349)!(ACRREFX=326),ACRCT["AUTH" S ACRCT="CONTRACT/ORDER OFFICER"
I (ACRCT["CERTIFY"!(ACRCT["CERTIFICATION OF TRA")!(ACRCT["TRAINING FUNDS AVAIL")),$E(DT,4,5)<10,$E(DT,1,3)+1700<$P(^ACRLOCB($P(ACRDOC0,U,6),"DT"),U) S ACRCT=" SUB. TO AVAIL FUNDS."
Q:$D(ACRORIGF)
I "^103^349^326^"'[(U_ACRREFX_U)!("^103^349^326^"[(U_ACRREFX_U)&(ACRFINAL'="Y")) D
.W !
.D B
.W ACRCT
.I $L(ACRCT)<21 F ACRI=1:1:21-$L(ACRCT) W "."
.W ": "
.W ?23,ACRUS
I ACRREFX=103!(ACRREFX=349)!(ACRREFX=326),ACRREFDA'=$O(^AUTTDOCR("B",116,0)),ACRFINAL="Y" D
.W !,$S($D(ACR3542):"9A. ",'$D(ACRPSC):"22. ",1:" "),"UNITED STATES OF AMERICA BY:"
.I '$D(ACRPSC) D
..W ?44,"|",$S($D(ACR3542):"",1:"23. "),"NAME: ",ACRUS
..W !?4,$S(ACRSTATS="A":"(ELECTRONIC SIGNATURE) "_$P(Y,"@"),1:"PENDING")
..W ?44,"|"
..W ?55,"CONTRACT/ORDER OFFICER"
..W ?51
.I $D(ACRPSC) D
..W ?$X+2,ACRUS
..W !?4,$S(ACRSTATS="A":"(ELECTRONIC SIGNATURE) "_$P(Y,"@"),1:"PENDING")
..W ?44,"CONTRACT/ORDER OFFICER"
..W ?51
I ACRREFX=103!(ACRREFX=349)!(ACRREFX=326),ACRFINAL="Y",ACRSTATS="A",$D(^ACROBL(ACRDOCDA,"APV")),$P(^("APV"),U,3)="A",$P(^ACRDOC(ACRDOCDA,0),U,12) D
.W !?20,"***** ",$S($P(^ACRDOC(ACRDOCDA,0),U,12)=1:"ADVANCE PAYMENT",1:"CASH BUY")," AUTHORIZED *****"
I "^103^349^326^"'[(U_ACRREFX_U)!("^103^349^326^"[(U_ACRREFX_U)&(ACRFINAL'="Y")) D
.W ?49,$S($E(ACRSTATS)["A":"APPROVED",$E(ACRSTATS)["D":"DISAPPRVD",1:"PENDING")
.W ?59,Y
W ?79 D B
I ACRUS'=ACRUSO,"^103^349^326^"'[(U_ACRREFX_U)!("^103^349^326^"[(U_ACRREFX_U)&(ACRFINAL'="Y")),ACRSTATS]"" D
.W !,"|"
.W ?22,"(ACTING FOR: ",ACRUSO,")"
.W ?79
.D B
Q
B W $S(ACRREFX'=103&(ACRREFX'=349)&(ACRREFX'=326):"|",1:"")
Q
B1 W $S(ACRREFX'=103&(ACRREFX'=349)&(ACRREFX'=326):"|",1:"-")
Q
ACRFPAPV ;IHS/OIRM/DSD/THL,AEF - PRINT APPROVALS ON REQUESTS; [ 10/27/2006 4:15 PM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**14,19,21**;NOV 05, 2001
+2 ;;ROUTINE TO PRINT APPROVALS AND TO DISPLAY STATUS OF A REQUEST
EN ;EP;
+1 IF $DATA(ACROUT)
QUIT
+2 IF "^116^204^103^349^326^210^"[(U_ACRREFX_U)
IF '$DATA(^ACRSS("J",ACRDOCDA))
DO CONSOL^ACRFPAP1
QUIT
+3 NEW ACRX,ACRY,ACRJ,D0
+4 IF $DATA(ACRDOCDA)
SET D0=ACRDOCDA
+5 DO EN1
+6 IF $EXTRACT(IOST,1,2)="C-"
IF '$DATA(ACRREF)!$DATA(ACRCOMP)!$DATA(ACRPRT)!$DATA(ACRPO)!$DATA(ACRREV)!$DATA(ACRCSI)
DO PAUSE^ACRFWARN
EXIT KILL ACRZ,Y,ACRCT,ACRSTATS
+1 QUIT
EN1 NEW ACRPHEAD
+1 SET (ACRPHEAD,ACRX)=0
+2 IF $PIECE(^ACRDOC(ACRDOCDA,0),U,19)
NEW ACRREFX
SET ACRREFX=116
+3 SET ACRREFDA=$ORDER(^AUTTDOCR("B",$SELECT(ACRREF'=210:ACRREFX,1:ACRREF),0))
+4 IF ACRREF=210
IF $DATA(ACRREQST)!(ACRREFX=116)
Begin DoDot:1
+5 SET ACRREFDA=$ORDER(^AUTTDOCR("B",116,0))
+6 SET ACRREFX=116
End DoDot:1
+7 IF '$DATA(ACRORIGF)
Begin DoDot:1
+8 FOR
SET ACRX=$ORDER(^ACRAPVS("AB",D0,ACRX))
IF 'ACRX
QUIT
IF $PIECE(^ACRAPVS(ACRX,0),U,6)=ACRREFDA!($PIECE($GET(ACRDOC0),U,4)=35)
SET ACRPHEAD=ACRPHEAD+1
+9 IF '$DATA(ACRORIGF)
DO PHEAD^ACRFSS12
End DoDot:1
+10 IF '$DATA(ACRPPO)
IF ACRREFX'=148
IF '$DATA(ACRCSI)
IF $EXTRACT($GET(IOST),1,2)="C-"
IF '$DATA(ACRREV)
WRITE @IOF
+11 WRITE !
+12 IF '$DATA(ACRPSC)
DO B1
+13 IF ACRREF'=148&'$DATA(ACRPSC)
WRITE "------------------------------------------------------------------------------"
+14 IF ACRREF=148
WRITE "---------------------- SECTION D - CLEARANCE ACTION ------------------------"
+15 IF '$DATA(ACRPSC)
DO B1
+16 SET ACRREFDA=$ORDER(^AUTTDOCR("B",$SELECT(ACRREF'=210:ACRREFX,1:ACRREF),0))
+17 IF ACRREF=210
IF $DATA(ACRREQST)!(ACRREFX=116)
Begin DoDot:1
+18 SET ACRREFDA=$ORDER(^AUTTDOCR("B",116,0))
+19 SET ACRREFX=116
End DoDot:1
+20 IF "^103^349^326^210^"[(U_ACRREFX_U)
IF '$DATA(ACRREV)
IF '$DATA(ACRPRT)
IF $DATA(^ACROBL(ACRDOCDA,"APV"))
IF $PIECE(^("APV"),U,6)
Begin DoDot:1
+21 WRITE !,$SELECT($PIECE(^ACROBL(ACRDOCDA,"APV"),U,6)=1:"FINAL",1:"PARTIAL")," RECEIVING REPORT COMPLETED"
QUIT
End DoDot:1
+22 SET (ACRX,ACRJ)=0
+23 FOR
SET ACRX=$ORDER(^ACRAPVS("AB",D0,ACRX))
IF 'ACRX
QUIT
IF $PIECE(^ACRAPVS(ACRX,0),U,6)=ACRREFDA!($PIECE($GET(ACRDOC0),U,4)=35)
Begin DoDot:1
+24 SET ACRAP0=$GET(^ACRAPVS(ACRX,0))
+25 SET ACRAPDT=$GET(^ACRAPVS(ACRX,"DT"))
+26 IF $PIECE(ACRAPDT,U,8)>DT
QUIT
+27 IF ACRAP0=""&(ACRAPDT="")
Begin DoDot:2
+28 SET DA=ACRX
+29 SET DIK="^ACRAPVS("
+30 DO DIK^ACRFDIC
End DoDot:2
QUIT
+31 DO EN11
End DoDot:1
+32 IF ACRJ=0
WRITE !
Begin DoDot:1
+33 ;ACR*2.1*21.05 IM22502
NEW ACRSTAT
+34 ;ACR*2.1*21.05 IM22502
SET ACRSTAT=$EXTRACT(ACROBLAP)
+35 IF ACRREFX'=103
IF ACRREFX'=349
IF ACRREFX'=326
IF ACRREFX'=600
IF ACRREFX'=210
Begin DoDot:2
+36 WRITE "THIS DOCUMENT HAS "
+37 ;Begin old code ACR*2.1*21.05 IM22502
+38 ;W $S($E(ACROBLAP)'="D":"NOT BEEN SUBMITTED FOR APPROVAL.",1:"BEEN DISAPPROVED.")
+39 ;Begin new code ACR*2.1*21
+40 IF ACRSTAT="D"
WRITE "BEEN DISAPPROVED."
QUIT
+41 IF ACRSTAT="C"
WRITE "BEEN CANCELLED."
QUIT
+42 WRITE "NOT BEEN SUBMITTED FOR APPROVAL."
+43 ;End new code
End DoDot:2
+44 IF ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)!(ACRREFX=210)
Begin DoDot:2
+45 ;I $E(ACROBLAP)="D" W $S(ACRDOC0["CANCELLED":"CANCELLED",1:"DISAPPROVED") Q ;ACR*2.1*21.05 IM22502
+46 ;ACR*2.1*21.05 IM22502
IF $EXTRACT(ACROBLAP)="D"!($EXTRACT(ACROBLAP)="C")
WRITE $SELECT(ACRDOC0["CANCELLED":"CANCELLED",1:"DISAPPROVED")
QUIT
+47 IF $PIECE(ACRDOC0,U,4)=35
IF $PIECE(ACROBLAP,U,8)="A"
WRITE "CREDIT CARD PURCHASE APPROVED AND COMPLETED"
QUIT
+48 WRITE "BEING PROCESSED IN PROCURMENT BY: "
+49 NEW ACRPA
+50 SET ACRPA=$PIECE($GET(^ACRDOC(D0,"PA")),U)
+51 IF 'ACRPA
WRITE "PURCHASING AGENT NOT SELECTED."
+52 ;E S ACRPA=$P(^VA(200,ACRPA,0),U),ACRPA=$P($P(ACRPA,",",2)," ")_" "_$P(ACRPA,",") ;ACR*2.1*19.02 IM16848
+53 ;ACR*2.1*19.02 IM16848
IF '$TEST
SET ACRPA=$$NAME2^ACRFUTL1(ACRPA)
SET ACRPA=$PIECE($PIECE(ACRPA,",",2)," ")_" "_$PIECE(ACRPA,",")
+54 IF ACRPA]""
WRITE ACRPA
+55 IF $DATA(^ACRDOC(ACRDOCDA,13))
Begin DoDot:3
+56 NEW ACR13
+57 SET ACR13=$PIECE(^ACRDOC(ACRDOCDA,13),U,4)
+58 IF ACR13]""
WRITE ?$X+2,"PO DUE BY: ",$EXTRACT(ACR13,4,5),"/",$EXTRACT(ACR13,6,7)
End DoDot:3
+59 DO PDOCSTAT^ACRFEA42
End DoDot:2
+60 ;Begin old code ACR*2.1*21.05 IM22502
+61 ;I ACRREFX=600 D
+62 ;.I $P(^ACROBL(ACRDOCDA,"APV"),U)="D" D Q
+63 ;..W "TRAVEL VOUCHER WAS DISAPPROVED."
+64 ;.W "TRAVEL VOUCHER BEING PREPARED."
+65 ;Begin new code ACR*2.1*21.05 IM22502
+66 IF ACRREFX=600
Begin DoDot:2
+67 IF $PIECE(^ACROBL(ACRDOCDA,"APV"),U)="D"!($PIECE(^ACROBL(ACRDOCDA,"APV"),U)="C")
Begin DoDot:3
+68 WRITE "TRAVEL VOUCHER WAS "
+69 WRITE $SELECT(ACRDOC0["CANCELLED":"CANCELLED",1:"DISAPPROVED")
End DoDot:3
QUIT
+70 WRITE "TRAVEL VOUCHER BEING PREPARED."
End DoDot:2
+71 ;End new code
End DoDot:1
QUIT
+72 IF ACRREFX'=103
IF ACRREFX'=349
IF ACRREFX'=326
Begin DoDot:1
+73 WRITE !,"| APPROVAL FOR DOCUMENT: ",ACRDOC
+74 ;ACR*2.1*14.01 IM12272
WRITE " ",$$EXPDN^ACRFUTL(ACRDOCDA)
+75 WRITE ?79,"|"
End DoDot:1
+76 SET ACRX=0
+77 FOR
SET ACRX=$ORDER(ACRX(ACRX))
IF 'ACRX
QUIT
DO EN12
+78 IF $EXTRACT($GET(IOST),1,2)="P-"&'$DATA(ACRPSC)
DO TAIL^ACRFPAP1
+79 QUIT
EN11 IF $PIECE(ACRDOC0,U,4)=35
IF $PIECE(ACRAP0,U,3)=1
IF $PIECE(ACRAP0,U,4)=1
SET $PIECE(ACRAP0,U,4)=999
+1 SET ACRX($PIECE(ACRAP0,U,4),$PIECE(ACRAP0,U,3),ACRX)=""
+2 SET ACRDOC=$SELECT($PIECE(ACRDOC0,U,2)]""&($PIECE(ACRDOC0,U,2)'=$PIECE(ACRDOC0,U))&'$DATA(ACRREQST):$PIECE(ACRDOC0,U,2)_" ("_$PIECE(ACRDOC0,U)_")",1:$PIECE(ACRDOC0,U))
+3 SET ACRJ=ACRJ+1
+4 QUIT
EN12 SET ACRY=0
+1 FOR
SET ACRY=$ORDER(ACRX(ACRX,ACRY))
IF 'ACRY
QUIT
Begin DoDot:1
+2 SET ACRZ=$ORDER(ACRX(ACRX,ACRY,0))
+3 SET ACRCT=$PIECE(^ACRAPVS(ACRZ,0),U,3)
+4 SET ACRDT=$GET(^ACRAPVS(ACRZ,"DT"))
+5 SET ACRSTATS=$PIECE(ACRDT,U)
+6 SET ACRFINAL=$PIECE(ACRDT,U,5)
+7 SET ACRUS=$SELECT($PIECE(ACRDT,U,6)]"":$PIECE(ACRDT,U,6),1:$PIECE(ACRDT,U,2))
+8 SET ACRUSO=$PIECE(ACRDT,U,2)
+9 SET Y=$PIECE(ACRDT,U,4)
End DoDot:1
+10 IF Y]""
XECUTE ^DD("DD")
+11 IF $DATA(ACRORIGF)
SET ACRAP=Y
+12 DO EN2
+13 QUIT
EN2 IF 'ACRCT
SET ACRCT="NOT STATED"
+1 IF ACRCT=1
IF ACRSTATS=""
Begin DoDot:1
+2 WRITE !
+3 DO B
+4 WRITE $SELECT($DATA(ACR3542):"9A. ",'$DATA(ACRPSC):"22. ",1:" "),"(DOCUMENT PENDING CONTRACT/ORDER OFFICER SIGNATURE)"
+5 WRITE ?79
+6 DO B
End DoDot:1
+7 IF ACRCT
IF '$DATA(^ACRAPVT(ACRCT,0))
SET ACRCT="NOT STATED"
+8 IF ACRCT
IF $DATA(^ACRAPVT(ACRCT,0))
Begin DoDot:1
+9 DO EN^ACRFPAP1
+10 SET ACRCT=$PIECE(^ACRAPVT(ACRCT,0),U)
End DoDot:1
+11 IF ACRX=99
SET ACRCT="RECERTIFY FUNDS"
+12 IF ACRUS
IF $DATA(^VA(200,ACRUS,0))
Begin DoDot:1
+13 ;S ACRUS=$E($P(^VA(200,ACRUS,0),U),1,24) ;ACR*2.1*19.02 IM16848
+14 ;ACR*2.1*19.02 IM16848
SET ACRUS=$EXTRACT($$NAME3^ACRFUTL1(ACRUS),1,24)
+15 SET ACRUS=$PIECE(ACRUS,",",2)_" "_$PIECE(ACRUS,",")
+16 IF ACRUSO'=ACRUS
IF $DATA(^VA(200,ACRUSO,0))
Begin DoDot:2
+17 ;S ACRUSO=$E($P(^VA(200,ACRUSO,0),U),1,24) ;ACR*2.1*19.02 IM16848
+18 ;ACR*2.1*19.02 IM16848
SET ACRUSO=$EXTRACT($$NAME3^ACRFUTL1(ACRUSO),1,24)
+19 SET ACRUSO=$PIECE(ACRUSO,",",2)_" "_$PIECE(ACRUSO,",")
End DoDot:2
IF 1
End DoDot:1
+20 IF '$TEST
SET ACRUS="NOT STATED"
+21 SET ACRCT=$EXTRACT($PIECE($PIECE(ACRCT,",",2)," ")_" "_$PIECE(ACRCT,","),1,21)
+22 IF ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)
IF ACRCT["AUTH"
SET ACRCT="CONTRACT/ORDER OFFICER"
+23 IF (ACRCT["CERTIFY"!(ACRCT["CERTIFICATION OF TRA")!(ACRCT["TRAINING FUNDS AVAIL"))
IF $EXTRACT(DT,4,5)<10
IF $EXTRACT(DT,1,3)+1700<$PIECE(^ACRLOCB($PIECE(ACRDOC0,U,6),"DT"),U)
SET ACRCT=" SUB. TO AVAIL FUNDS."
+24 IF $DATA(ACRORIGF)
QUIT
+25 IF "^103^349^326^"'[(U_ACRREFX_U)!("^103^349^326^"[(U_ACRREFX_U)&(ACRFINAL'="Y"))
Begin DoDot:1
+26 WRITE !
+27 DO B
+28 WRITE ACRCT
+29 IF $LENGTH(ACRCT)<21
FOR ACRI=1:1:21-$LENGTH(ACRCT)
WRITE "."
+30 WRITE ": "
+31 WRITE ?23,ACRUS
End DoDot:1
+32 IF ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)
IF ACRREFDA'=$ORDER(^AUTTDOCR("B",116,0))
IF ACRFINAL="Y"
Begin DoDot:1
+33 WRITE !,$SELECT($DATA(ACR3542):"9A. ",'$DATA(ACRPSC):"22. ",1:" "),"UNITED STATES OF AMERICA BY:"
+34 IF '$DATA(ACRPSC)
Begin DoDot:2
+35 WRITE ?44,"|",$SELECT($DATA(ACR3542):"",1:"23. "),"NAME: ",ACRUS
+36 WRITE !?4,$SELECT(ACRSTATS="A":"(ELECTRONIC SIGNATURE) "_$PIECE(Y,"@"),1:"PENDING")
+37 WRITE ?44,"|"
+38 WRITE ?55,"CONTRACT/ORDER OFFICER"
+39 WRITE ?51
End DoDot:2
+40 IF $DATA(ACRPSC)
Begin DoDot:2
+41 WRITE ?$X+2,ACRUS
+42 WRITE !?4,$SELECT(ACRSTATS="A":"(ELECTRONIC SIGNATURE) "_$PIECE(Y,"@"),1:"PENDING")
+43 WRITE ?44,"CONTRACT/ORDER OFFICER"
+44 WRITE ?51
End DoDot:2
End DoDot:1
+45 IF ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)
IF ACRFINAL="Y"
IF ACRSTATS="A"
IF $DATA(^ACROBL(ACRDOCDA,"APV"))
IF $PIECE(^("APV"),U,3)="A"
IF $PIECE(^ACRDOC(ACRDOCDA,0),U,12)
Begin DoDot:1
+46 WRITE !?20,"***** ",$SELECT($PIECE(^ACRDOC(ACRDOCDA,0),U,12)=1:"ADVANCE PAYMENT",1:"CASH BUY")," AUTHORIZED *****"
End DoDot:1
+47 IF "^103^349^326^"'[(U_ACRREFX_U)!("^103^349^326^"[(U_ACRREFX_U)&(ACRFINAL'="Y"))
Begin DoDot:1
+48 WRITE ?49,$SELECT($EXTRACT(ACRSTATS)["A":"APPROVED",$EXTRACT(ACRSTATS)["D":"DISAPPRVD",1:"PENDING")
+49 WRITE ?59,Y
End DoDot:1
+50 WRITE ?79
DO B
+51 IF ACRUS'=ACRUSO
IF "^103^349^326^"'[(U_ACRREFX_U)!("^103^349^326^"[(U_ACRREFX_U)&(ACRFINAL'="Y"))
IF ACRSTATS]""
Begin DoDot:1
+52 WRITE !,"|"
+53 WRITE ?22,"(ACTING FOR: ",ACRUSO,")"
+54 WRITE ?79
+55 DO B
End DoDot:1
+56 QUIT
B WRITE $SELECT(ACRREFX'=103&(ACRREFX'=349)&(ACRREFX'=326):"|",1:"")
+1 QUIT
B1 WRITE $SELECT(ACRREFX'=103&(ACRREFX'=349)&(ACRREFX'=326):"|",1:"-")
+1 QUIT
