ACRFPSS ;IHS/OIRM/DSD/THL,AEF - SUMMARIZED FINANCIAL DATA FOR SERVICES AND SUPPLIES; [ 05/09/2005 10:25 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**3,16,17**;NOV 05, 2001
;;SUMMARIZE DOCUMENT FINANCE DATA
EN Q:$D(ACROUT)
I $D(ACRDOCDA),$D(^ACRDOC(ACRDOCDA,0)),$P(^(0),U,18)>0 Q
K ACROBJ,ACRCAN
D EN1
EXIT D:'$D(ACRPSUM) PAUSE^ACRFWARN
Q
EN1 ;EP;
N ACRY,ACR,ACRI,ACRX,ACRCAN,ACR1,ACR2,ACR3,ACRTOT,ACRSSRQD,ACRRX,ACRPHONE
I ACRREFX=116,'$P(^ACRDOC(ACRDOCDA,0),U,19),$L($P(^ACRSYS(1,"DT"),U,19,20))>2000 D EXCEED^ACRFSS12
S ACRXREF=$S(ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)!(ACRREFX=499)!($P(^ACRDOC(ACRDOCDA,0),U,4)=35&($P($G(^ACROBL(ACRDOCDA,"APV")),U)="A")):"J",1:"C")
S (ACRX,D0)=ACRDOCDA
S (ACRTOT,ACRY)=0
F S ACRY=$O(^ACRSS(ACRXREF,ACRX,ACRY)) Q:'ACRY!$D(ACRSSRQD) D EN11
I $D(ACRSSRQD) D Q
.W !!,"REQUIRED FINANCIAL DATA MISSING. FINANCIAL SUMMARY CANNOT BE COMPLETED."
I $D(ACROBJ) D
.D PRINT
.D QUAN^ACRFSS12
Q
EN11 S ACR=^ACRSS(ACRY,0)
S ACRLBDA=$P(ACR,U,6)
S ACR1=$P(ACR,U,4)
S ACR2=$P(ACR,U,5)
S ACR=$P(ACR,U)
S ACR3=$P($G(^ACRSS(ACRY,"DT")),U,4)
S ACRDESC=$P($G(^ACRSS(ACRY,"NMS")),U,5)
I ACR1=""!(ACR2="") S ACRSSRQD="" Q
I $D(ACRREFX),ACRREFX=499,$D(ACRRRNO) D I $D(ACRQUIT) K ACRQUIT Q
.S ACRQUIT=""
.S ACRRX=0
.F S ACRRX=$O(^ACRRR("AC",ACRDOCDA,ACRRRNO,ACRRX)) Q:'ACRRX D
..S ACRRRDA=0
..F S ACRRRDA=$O(^ACRRR("AC",ACRDOCDA,ACRRRNO,ACRRX,ACRRRDA)) Q:'ACRRRDA D
...I $D(^ACRRR(ACRRRDA,0)),$D(^ACRRR(ACRRRDA,"DT")),$D(^ACRRR(ACRRRDA,0)),ACRY=+^(0) D
....S ACR3=$P(^ACRRR(ACRRRDA,"DT"),U,2)*$P($G(^ACRSS(+^ACRRR(ACRRRDA,0),"DT")),U,3)
....K ACRQUIT
....S DA=ACRRRDA
....S DIE="^ACRRR("
....S DR=".14////1"
....D DIE^ACRFDIC
SETS D SETACT
I ACRREFX=130!(ACRREFX=600) K ACRALTOT D ALTOT^ACRFSSA1
S:'$D(ACROBJ(ACRACT,ACR2,ACR1)) ACROBJ(ACRACT,ACR2,ACR1)=0,ACROBJ(ACRACT,ACR2,ACR1,"I")=""
I "^130^600^"[(U_ACRREFX_U),ACRDESC["Travel-DHHS",$P(^ACRDOC(ACRDOCDA,"TOAU"),U,5)'=1 D ALADJST
S ACROBJ(ACRACT,ACR2,ACR1)=ACROBJ(ACRACT,ACR2,ACR1)+ACR3
I "^130^600^"[(U_ACRREFX_U),ACRDESC["Other Exp-DHHS",$P($G(^ACRDOC(ACRDOCDA,"TRNG4")),U,16) S ACROBJ(ACRACT,ACR2,ACR1)=$P(^("TRNG4"),U,16)-$G(ACRALTOT)
;IF MAX DOLLARS INDICATED FOR CONTINUING EDUCATION
;ENSURE THAT MAX NOT EXCEEDED IN OBLIGATION OR PAYMENT
S ACROBJ(ACRACT,ACR2,ACR1,"I")=ACROBJ(ACRACT,ACR2,ACR1,"I")_$S(ACROBJ(ACRACT,ACR2,ACR1,"I")]"":",",1:"")_ACR
S:'$D(ACRCAN(ACRACT,ACR2)) ACRCAN(ACRACT,ACR2)=0
S ACRCAN(ACRACT,ACR2)=ACRCAN(ACRACT,ACR2)+ACR3
S ACRTOT=ACRTOT+ACR3
Q
PRINT ;EP;
I '$D(ACRORIGF) S ACRPHEAD=5 D PHEAD^ACRFSS12
HEAD S:'$D(ACRREF) ACRREF=ACRREF1
S:'$D(ACRREFX) ACRREFX=ACRREF
W !
D B1
W:'$D(ACRORIGF) "---------------------",$S(ACRREF'=148:"---------------------------",1:" SECTION C - FISCAL DATA "),"------------------------------"
D B1
D H1
S ACRACT=""
F S ACRACT=$O(ACROBJ(ACRACT)) Q:ACRACT="" D
.D ACT
.S (ACRCAN,ACROBJ)=0
.F S ACRCAN=$O(ACROBJ(ACRACT,ACRCAN)) Q:'ACRCAN D P1
S ACRI=$G(ACRI) ;ACR*2.1*17.02 IM16906
I ACRREFX=499,ACRI>1 D
.W !?20,"--------------"
.W !?10,"TOTAL:",?19,$J($FN(ACRTOT,"P,",2),14)
S ACRSSTOT=ACRTOT
Q
P1 S ACR1=ACRCAN(ACRACT,ACRCAN)
W !
D B
W:+$G(ACRPSC)'=26&($G(ACRPSC)'=33) ?5
W:+$G(ACRPSC)=26!(+$G(ACRPSC)=33) ?41
W $P(^AUTTCAN(ACRCAN,0),U)," "
S ACRSSADA=$P(^AUTTCAN(ACRCAN,0),U,6)
D P2
Q
P2 S ACRI=0
F S ACROBJ=$O(ACROBJ(ACRACT,ACRCAN,ACROBJ)) Q:'ACROBJ D P3
I '$D(ACRORIGF),$E($G(IOST),1,2)="P-",$Y>(IOSL-4) S ACRPHEAD=5 D PHEAD^ACRFSS12
Q
P3 S ACR2=ACROBJ(ACRACT,ACRCAN,ACROBJ),ACRI=ACRI+1
I ACRI>1 W ! D B
I $D(ACRORIGF),+$G(ACRPSC)=1449 W ?49
W:+$G(ACRPSC)=26!(+$G(ACRPSC)=33) ?60
W:+$G(ACRPSC)=347 ?14
W:+$G(ACRPSC)'=26 ?14
W:+$G(ACRPSC)=26 ?41
W $P(^AUTTOBJC(ACROBJ,0),U)
W:'$D(ACRORIGF) $J($FN(ACR2,"P,",2),14)
I $D(ACROBJ(ACRACT,ACRCAN,ACROBJ,"A"))#2 W !?4,"(REF CODE ",$P($G(^AUTTDOCR(+$P($G(^ACRSYS(+$G(ACRADA),"DT")),U,35),0)),U),?18,$J($FN(ACROBJ(ACRACT,ACRCAN,ACROBJ,"A"),"P,",2),14),")"
I $D(ACRORIGF) D
.W:ACRI=1 $J($FN(ACR1,"P,",2),10)
.W ?28,$J($FN(ACR2,"P,",2),10)
I +$G(ACRPSC)=347,$G(ACR11)]"",$Y=22 D 11^ACRF3472
;W:"^103^349^326^130^600^148^"'[(U_ACRREFX_U) ?48,$P(ACROBJ(ACRACT,ACRCAN,ACROBJ,"I"),",",1,5) ;ACR*2.1*16.03 IM13679
W:"^103^349^326^130^600^148^"'[(U_ACRREFX_U) ?48,$P(ACROBJ(ACRACT,ACRCAN,ACROBJ,"I"),",",1,6) ;ACR*2.1*16.03 IM13679
I (ACRREFX=103!(ACRREFX=349)!(ACRREFX=326))&'$D(ACR3542)!("^130^600^"[(U_ACRREFX_U)) D
.I $D(ACRTOB),'$D(ACRORIGF),ACRI=1 W ?39,"| ",ACRTOB
.I ACRI>1,'$D(ACRORIGF) W ?39,"|"
.K ACRCONC
.I $D(^ACRAL("E",ACRDOCDA)) D
..N ACRALDA
..S ACRALDA=0
..F S ACRALDA=$O(^ACRAL("E",ACRDOCDA,ACRALDA)) Q:'ACRALDA!$D(ACRCONC) I +$P($G(^ACRAL(ACRALDA,"DT")),U,11) S ACRCONC=$P(^("DT"),U,11)
.W:$D(ACRCONC) ?45,"NON-CONTRACT CODE: ",ACRCONC
.K ACRCONC
W ?79
D B
;F ACRCNT=6:5 Q:$P(ACROBJ(ACRACT,ACRCAN,ACROBJ,"I"),",",ACRCNT)="" D ;ACR*2.1*16.03 IM13679
F ACRCNT=7:6 Q:$P(ACROBJ(ACRACT,ACRCAN,ACROBJ,"I"),",",ACRCNT)="" D ;ACR*2.1*16.03 IM13679
.I "^130^103^349^326^600^148^"'[(U_ACRREFX_U) D
..W !,"|"
..W ?48,$P(ACROBJ(ACRACT,ACRCAN,ACROBJ,"I"),",",ACRCNT,ACRCNT+5)
..W ?79,"|"
Q
H1 ;I ACRREFX=130 D ALTOT^ACRFSSA1
D
.I ACRREFX'=148,'$D(ACRORIGF) D
..D PPO:ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)
..W !
..D B
..W:ACRREFX=103&'$D(ACR3542) "9."
..W:ACRREFX'=148 " ACCOUNTING AND APPROPRIATION DATA"
..W:ACRREFX=103&'$D(ACR3542) ?39,"|10. REQUISITIONING OFFICE",$S(ACRPHONE]"":" ("_ACRPHONE_")",1:"")
..W ?79
..D B
..W !
..D B
..W "---------------------------------------"
..W:ACRREFX=103&$D(ACRROFF)&'$D(ACR3542) ?39,"| ",ACRROFF
..W ?79
..D B
.S ACRLBDA=$P(ACRDOC0,U,6)
H11 Q
PPO ;DATA FOR PRINTING PURCHASE ORDER
S ACRROFF=$P($G(^ACRDOC(ACRDOCDA,"PO")),U,7)
S ACRTOB=$P($G(^ACRDOC(ACRDOCDA,"PO")),U,5)
S ACRPHONE=$P(^ACRDOC(ACRDOCDA,"REQ"),U,8)
I ACRROFF,$D(^AUTTPRG(ACRROFF,0)) S ACRROFF=$P(^(0),U)
I ACRTOB,$D(^AUTTVNDR(ACRTOB,11)) S ACRTOB=$P(^(11),U,26)
I ACRTOB,$D(^AUTTTOB(ACRTOB,0)) S ACRTOB=$P(^(0),U,2)
Q
B Q:$D(ACRORIGF)
W $S(ACRREFX'=103&(ACRREFX'=349)&(ACRREFX'=326):"|",1:"")
Q
B1 Q:$D(ACRORIGF)
W $S(ACRREFX'=103&(ACRREFX'=349)&(ACRREFX'=326):"|",1:"-")
Q
ALADJST ;ADJUST FINACIAL SUMMARY TO EXCLUDE AIRLINE EXPENSE AND TO CREATE
;SEPARATE DHR FOR AIRLINE EXPENSE WHEN INDICATED
N ACRREFA
I $G(ACRADA),ACRREFX=130!(ACRREFX=600),$P(^ACRSYS(ACRADA,"DT"),U,33) D Q:$G(ACRREFA)=""
.I $P(^ACRSYS(ACRADA,"DT"),U,35) S ACRREFA=$P($G(^AUTTDOCR(+$P(^("DT"),U,35),0)),U) K:ACRREFA=ACRREFX ACRREFA
I '$D(ACRCANCL),$G(ACRADA),ACRREFX=600,$P(^ACRSYS(ACRADA,"DT"),U,34) Q ;IF THIS IS A TO CANCELLATION, CREATE SEPARATE AIRLINE DHR EVEN IF AIRFARE ON PMT DHR IS SET TO YES
S ACR3=ACR3-$G(ACRALTOT)
I $G(ACRALTOT),$G(ACRREFA)]"" S ACROBJ(ACRACT,ACR2,ACR1,"A")=ACRALTOT
Q
ACT ;WRITE ACCOUNTING INFO
W !
D B
;W:+$G(ACRPSC)'=26&($G(ACRPSC)'=33) ?2 ;ACR*2.1*3.40
;W:+$G(ACRPSC)=26!(+$G(ACRPSC)=33) ?41 ;ACR*2.1*3.40
W:+$G(ACRPSC)'=26&($G(ACRPSC)'=33) ?0 ;ACR*2.1*3.40
W:+$G(ACRPSC)=26!(+$G(ACRPSC)=33) ?38 ;ACR*2.1*3.40
W ACRACT
W:ACRREFX=103&'$D(ACR3542)&'$D(ACRORIGF) ?39,"|11. BUSINESS CLASSIFICATION" ;ACR*2.1*3.40
I ACRREFX=130,$G(ACRALTOT) W ?45,"(AIRLINE EXPENSE: ",$FN(ACRALTOT,"P,",2),")"
W ?79
D B
Q
SETACT ;EP;TO SET ACCOUNTING DATA
S ACRDPT=$P(^ACRLOCB(ACRLBDA,0),U,5)
S ACRDT=^ACRLOCB(ACRLBDA,"DT")
N ACRPJNUM
S ACRPJNUM=$P($G(^ACRLOCB(ACRLBDA,3)),U)
S ACRFY=$P(ACRDT,U)
S ACRAPPDA=$P(ACRDT,U,4)
S ACRALWDA=$P(ACRDT,U,5)
S ACRSSADA=$P(ACRDT,U,8)
S (ACRCAN,ACRCANDA)=$P(ACRDT,U,9)
S ACRLCOD=$P(ACRDT,U,11)
S ACRCCTDA=$P(ACRDT,U,15)
S ACRDPT=$P(^AUTTPRG(ACRDPT,0),U,6)
K ACRCCT
I ACRCCTDA,$D(^AUTTCCT(ACRCCTDA,0)) S ACRCCT=$P(^(0),U)
I '$D(ACRCCT),ACRCANDA,$D(^AUTTCAN(ACRCANDA,0)) S ACRCCT=$E($P(^(0),U),6,7)
S ACRAPP=$P(^AUTTPRO(ACRAPPDA,0),U)
S ACRALW=$P(^AUTTALLW(ACRALWDA,0),U)
S ACRSSA=$P(^AUTTSSA(ACRSSADA,0),U,3)
S ACRLCOD=$E($P(^AUTTLCOD(ACRLCOD,0),U),2,3)_"."_$P($G(^AUTTLCOD(ACRLCOD,"DT")),U,2)
S ACRACT=ACRAPP_" "_ACRFY_"-"_ACRALW_"."_ACRSSA_"."_($S(ACRPJNUM]"":ACRPJNUM,1:(ACRDPT_ACRCCT)))_"."_ACRLCOD ;ACR*2.1*3.40
Q
ACRFPSS ;IHS/OIRM/DSD/THL,AEF - SUMMARIZED FINANCIAL DATA FOR SERVICES AND SUPPLIES; [ 05/09/2005 10:25 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**3,16,17**;NOV 05, 2001
+2 ;;SUMMARIZE DOCUMENT FINANCE DATA
EN IF $DATA(ACROUT)
QUIT
+1 IF $DATA(ACRDOCDA)
IF $DATA(^ACRDOC(ACRDOCDA,0))
IF $PIECE(^(0),U,18)>0
QUIT
+2 KILL ACROBJ,ACRCAN
+3 DO EN1
EXIT IF '$DATA(ACRPSUM)
DO PAUSE^ACRFWARN
+1 QUIT
EN1 ;EP;
+1 NEW ACRY,ACR,ACRI,ACRX,ACRCAN,ACR1,ACR2,ACR3,ACRTOT,ACRSSRQD,ACRRX,ACRPHONE
+2 IF ACRREFX=116
IF '$PIECE(^ACRDOC(ACRDOCDA,0),U,19)
IF $LENGTH($PIECE(^ACRSYS(1,"DT"),U,19,20))>2000
DO EXCEED^ACRFSS12
+3 SET ACRXREF=$SELECT(ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)!(ACRREFX=499)!($PIECE(^ACRDOC(ACRDOCDA,0),U,4)=35&($PIECE($GET(^ACROBL(ACRDOCDA,"APV")),U)="A")):"J",1:"C")
+4 SET (ACRX,D0)=ACRDOCDA
+5 SET (ACRTOT,ACRY)=0
+6 FOR
SET ACRY=$ORDER(^ACRSS(ACRXREF,ACRX,ACRY))
IF 'ACRY!$DATA(ACRSSRQD)
QUIT
DO EN11
+7 IF $DATA(ACRSSRQD)
Begin DoDot:1
+8 WRITE !!,"REQUIRED FINANCIAL DATA MISSING. FINANCIAL SUMMARY CANNOT BE COMPLETED."
End DoDot:1
QUIT
+9 IF $DATA(ACROBJ)
Begin DoDot:1
+10 DO PRINT
+11 DO QUAN^ACRFSS12
End DoDot:1
+12 QUIT
EN11 SET ACR=^ACRSS(ACRY,0)
+1 SET ACRLBDA=$PIECE(ACR,U,6)
+2 SET ACR1=$PIECE(ACR,U,4)
+3 SET ACR2=$PIECE(ACR,U,5)
+4 SET ACR=$PIECE(ACR,U)
+5 SET ACR3=$PIECE($GET(^ACRSS(ACRY,"DT")),U,4)
+6 SET ACRDESC=$PIECE($GET(^ACRSS(ACRY,"NMS")),U,5)
+7 IF ACR1=""!(ACR2="")
SET ACRSSRQD=""
QUIT
+8 IF $DATA(ACRREFX)
IF ACRREFX=499
IF $DATA(ACRRRNO)
Begin DoDot:1
+9 SET ACRQUIT=""
+10 SET ACRRX=0
+11 FOR
SET ACRRX=$ORDER(^ACRRR("AC",ACRDOCDA,ACRRRNO,ACRRX))
IF 'ACRRX
QUIT
Begin DoDot:2
+12 SET ACRRRDA=0
+13 FOR
SET ACRRRDA=$ORDER(^ACRRR("AC",ACRDOCDA,ACRRRNO,ACRRX,ACRRRDA))
IF 'ACRRRDA
QUIT
Begin DoDot:3
+14 IF $DATA(^ACRRR(ACRRRDA,0))
IF $DATA(^ACRRR(ACRRRDA,"DT"))
IF $DATA(^ACRRR(ACRRRDA,0))
IF ACRY=+^(0)
Begin DoDot:4
+15 SET ACR3=$PIECE(^ACRRR(ACRRRDA,"DT"),U,2)*$PIECE($GET(^ACRSS(+^ACRRR(ACRRRDA,0),"DT")),U,3)
+16 KILL ACRQUIT
+17 SET DA=ACRRRDA
+18 SET DIE="^ACRRR("
+19 SET DR=".14////1"
+20 DO DIE^ACRFDIC
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
IF $DATA(ACRQUIT)
KILL ACRQUIT
QUIT
SETS DO SETACT
+1 IF ACRREFX=130!(ACRREFX=600)
KILL ACRALTOT
DO ALTOT^ACRFSSA1
+2 IF '$DATA(ACROBJ(ACRACT,ACR2,ACR1))
SET ACROBJ(ACRACT,ACR2,ACR1)=0
SET ACROBJ(ACRACT,ACR2,ACR1,"I")=""
+3 IF "^130^600^"[(U_ACRREFX_U)
IF ACRDESC["Travel-DHHS"
IF $PIECE(^ACRDOC(ACRDOCDA,"TOAU"),U,5)'=1
DO ALADJST
+4 SET ACROBJ(ACRACT,ACR2,ACR1)=ACROBJ(ACRACT,ACR2,ACR1)+ACR3
+5 IF "^130^600^"[(U_ACRREFX_U)
IF ACRDESC["Other Exp-DHHS"
IF $PIECE($GET(^ACRDOC(ACRDOCDA,"TRNG4")),U,16)
SET ACROBJ(ACRACT,ACR2,ACR1)=$PIECE(^("TRNG4"),U,16)-$GET(ACRALTOT)
+6 ;IF MAX DOLLARS INDICATED FOR CONTINUING EDUCATION
+7 ;ENSURE THAT MAX NOT EXCEEDED IN OBLIGATION OR PAYMENT
+8 SET ACROBJ(ACRACT,ACR2,ACR1,"I")=ACROBJ(ACRACT,ACR2,ACR1,"I")_$SELECT(ACROBJ(ACRACT,ACR2,ACR1,"I")]"":",",1:"")_ACR
+9 IF '$DATA(ACRCAN(ACRACT,ACR2))
SET ACRCAN(ACRACT,ACR2)=0
+10 SET ACRCAN(ACRACT,ACR2)=ACRCAN(ACRACT,ACR2)+ACR3
+11 SET ACRTOT=ACRTOT+ACR3
+12 QUIT
PRINT ;EP;
+1 IF '$DATA(ACRORIGF)
SET ACRPHEAD=5
DO PHEAD^ACRFSS12
HEAD IF '$DATA(ACRREF)
SET ACRREF=ACRREF1
+1 IF '$DATA(ACRREFX)
SET ACRREFX=ACRREF
+2 WRITE !
+3 DO B1
+4 IF '$DATA(ACRORIGF)
WRITE "---------------------",$SELECT(ACRREF'=148:"---------------------------",1:" SECTION C - FISCAL DATA "),"------------------------------"
+5 DO B1
+6 DO H1
+7 SET ACRACT=""
+8 FOR
SET ACRACT=$ORDER(ACROBJ(ACRACT))
IF ACRACT=""
QUIT
Begin DoDot:1
+9 DO ACT
+10 SET (ACRCAN,ACROBJ)=0
+11 FOR
SET ACRCAN=$ORDER(ACROBJ(ACRACT,ACRCAN))
IF 'ACRCAN
QUIT
DO P1
End DoDot:1
+12 ;ACR*2.1*17.02 IM16906
SET ACRI=$GET(ACRI)
+13 IF ACRREFX=499
IF ACRI>1
Begin DoDot:1
+14 WRITE !?20,"--------------"
+15 WRITE !?10,"TOTAL:",?19,$JUSTIFY($FNUMBER(ACRTOT,"P,",2),14)
End DoDot:1
+16 SET ACRSSTOT=ACRTOT
+17 QUIT
P1 SET ACR1=ACRCAN(ACRACT,ACRCAN)
+1 WRITE !
+2 DO B
+3 IF +$GET(ACRPSC)'=26&($GET(ACRPSC)'=33)
WRITE ?5
+4 IF +$GET(ACRPSC)=26!(+$GET(ACRPSC)=33)
WRITE ?41
+5 WRITE $PIECE(^AUTTCAN(ACRCAN,0),U)," "
+6 SET ACRSSADA=$PIECE(^AUTTCAN(ACRCAN,0),U,6)
+7 DO P2
+8 QUIT
P2 SET ACRI=0
+1 FOR
SET ACROBJ=$ORDER(ACROBJ(ACRACT,ACRCAN,ACROBJ))
IF 'ACROBJ
QUIT
DO P3
+2 IF '$DATA(ACRORIGF)
IF $EXTRACT($GET(IOST),1,2)="P-"
IF $Y>(IOSL-4)
SET ACRPHEAD=5
DO PHEAD^ACRFSS12
+3 QUIT
P3 SET ACR2=ACROBJ(ACRACT,ACRCAN,ACROBJ)
SET ACRI=ACRI+1
+1 IF ACRI>1
WRITE !
DO B
+2 IF $DATA(ACRORIGF)
IF +$GET(ACRPSC)=1449
WRITE ?49
+3 IF +$GET(ACRPSC)=26!(+$GET(ACRPSC)=33)
WRITE ?60
+4 IF +$GET(ACRPSC)=347
WRITE ?14
+5 IF +$GET(ACRPSC)'=26
WRITE ?14
+6 IF +$GET(ACRPSC)=26
WRITE ?41
+7 WRITE $PIECE(^AUTTOBJC(ACROBJ,0),U)
+8 IF '$DATA(ACRORIGF)
WRITE $JUSTIFY($FNUMBER(ACR2,"P,",2),14)
+9 IF $DATA(ACROBJ(ACRACT,ACRCAN,ACROBJ,"A"))#2
WRITE !?4,"(REF CODE ",$PIECE($GET(^AUTTDOCR(+$PIECE($GET(^ACRSYS(+$GET(ACRADA),"DT")),U,35),0)),U),?18,$JUSTIFY($FNUMBER(ACROBJ(ACRACT,ACRCAN,ACROBJ,"A"),"P,",2),14),")"
+10 IF $DATA(ACRORIGF)
Begin DoDot:1
+11 IF ACRI=1
WRITE $JUSTIFY($FNUMBER(ACR1,"P,",2),10)
+12 WRITE ?28,$JUSTIFY($FNUMBER(ACR2,"P,",2),10)
End DoDot:1
+13 IF +$GET(ACRPSC)=347
IF $GET(ACR11)]""
IF $Y=22
DO 11^ACRF3472
+14 ;W:"^103^349^326^130^600^148^"'[(U_ACRREFX_U) ?48,$P(ACROBJ(ACRACT,ACRCAN,ACROBJ,"I"),",",1,5) ;ACR*2.1*16.03 IM13679
+15 ;ACR*2.1*16.03 IM13679
IF "^103^349^326^130^600^148^"'[(U_ACRREFX_U)
WRITE ?48,$PIECE(ACROBJ(ACRACT,ACRCAN,ACROBJ,"I"),",",1,6)
+16 IF (ACRREFX=103!(ACRREFX=349)!(ACRREFX=326))&'$DATA(ACR3542)!("^130^600^"[(U_ACRREFX_U))
Begin DoDot:1
+17 IF $DATA(ACRTOB)
IF '$DATA(ACRORIGF)
IF ACRI=1
WRITE ?39,"| ",ACRTOB
+18 IF ACRI>1
IF '$DATA(ACRORIGF)
WRITE ?39,"|"
+19 KILL ACRCONC
+20 IF $DATA(^ACRAL("E",ACRDOCDA))
Begin DoDot:2
+21 NEW ACRALDA
+22 SET ACRALDA=0
+23 FOR
SET ACRALDA=$ORDER(^ACRAL("E",ACRDOCDA,ACRALDA))
IF 'ACRALDA!$DATA(ACRCONC)
QUIT
IF +$PIECE($GET(^ACRAL(ACRALDA,"DT")),U,11)
SET ACRCONC=$PIECE(^("DT"),U,11)
End DoDot:2
+24 IF $DATA(ACRCONC)
WRITE ?45,"NON-CONTRACT CODE: ",ACRCONC
+25 KILL ACRCONC
End DoDot:1
+26 WRITE ?79
+27 DO B
+28 ;F ACRCNT=6:5 Q:$P(ACROBJ(ACRACT,ACRCAN,ACROBJ,"I"),",",ACRCNT)="" D ;ACR*2.1*16.03 IM13679
+29 ;ACR*2.1*16.03 IM13679
FOR ACRCNT=7:6
IF $PIECE(ACROBJ(ACRACT,ACRCAN,ACROBJ,"I"),",",ACRCNT)=""
QUIT
Begin DoDot:1
+30 IF "^130^103^349^326^600^148^"'[(U_ACRREFX_U)
Begin DoDot:2
+31 WRITE !,"|"
+32 WRITE ?48,$PIECE(ACROBJ(ACRACT,ACRCAN,ACROBJ,"I"),",",ACRCNT,ACRCNT+5)
+33 WRITE ?79,"|"
End DoDot:2
End DoDot:1
+34 QUIT
H1 ;I ACRREFX=130 D ALTOT^ACRFSSA1
+1 Begin DoDot:1
+2 IF ACRREFX'=148
IF '$DATA(ACRORIGF)
Begin DoDot:2
+3 IF ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)
DO PPO
+4 WRITE !
+5 DO B
+6 IF ACRREFX=103&'$DATA(ACR3542)
WRITE "9."
+7 IF ACRREFX'=148
WRITE " ACCOUNTING AND APPROPRIATION DATA"
+8 IF ACRREFX=103&'$DATA(ACR3542)
WRITE ?39,"|10. REQUISITIONING OFFICE",$SELECT(ACRPHONE]"":" ("_ACRPHONE_")",1:"")
+9 WRITE ?79
+10 DO B
+11 WRITE !
+12 DO B
+13 WRITE "---------------------------------------"
+14 IF ACRREFX=103&$DATA(ACRROFF)&'$DATA(ACR3542)
WRITE ?39,"| ",ACRROFF
+15 WRITE ?79
+16 DO B
End DoDot:2
+17 SET ACRLBDA=$PIECE(ACRDOC0,U,6)
End DoDot:1
H11 QUIT
PPO ;DATA FOR PRINTING PURCHASE ORDER
+1 SET ACRROFF=$PIECE($GET(^ACRDOC(ACRDOCDA,"PO")),U,7)
+2 SET ACRTOB=$PIECE($GET(^ACRDOC(ACRDOCDA,"PO")),U,5)
+3 SET ACRPHONE=$PIECE(^ACRDOC(ACRDOCDA,"REQ"),U,8)
+4 IF ACRROFF
IF $DATA(^AUTTPRG(ACRROFF,0))
SET ACRROFF=$PIECE(^(0),U)
+5 IF ACRTOB
IF $DATA(^AUTTVNDR(ACRTOB,11))
SET ACRTOB=$PIECE(^(11),U,26)
+6 IF ACRTOB
IF $DATA(^AUTTTOB(ACRTOB,0))
SET ACRTOB=$PIECE(^(0),U,2)
+7 QUIT
B IF $DATA(ACRORIGF)
QUIT
+1 WRITE $SELECT(ACRREFX'=103&(ACRREFX'=349)&(ACRREFX'=326):"|",1:"")
+2 QUIT
B1 IF $DATA(ACRORIGF)
QUIT
+1 WRITE $SELECT(ACRREFX'=103&(ACRREFX'=349)&(ACRREFX'=326):"|",1:"-")
+2 QUIT
ALADJST ;ADJUST FINACIAL SUMMARY TO EXCLUDE AIRLINE EXPENSE AND TO CREATE
+1 ;SEPARATE DHR FOR AIRLINE EXPENSE WHEN INDICATED
+2 NEW ACRREFA
+3 IF $GET(ACRADA)
IF ACRREFX=130!(ACRREFX=600)
IF $PIECE(^ACRSYS(ACRADA,"DT"),U,33)
Begin DoDot:1
+4 IF $PIECE(^ACRSYS(ACRADA,"DT"),U,35)
SET ACRREFA=$PIECE($GET(^AUTTDOCR(+$PIECE(^("DT"),U,35),0)),U)
IF ACRREFA=ACRREFX
KILL ACRREFA
End DoDot:1
IF $GET(ACRREFA)=""
QUIT
+5 ;IF THIS IS A TO CANCELLATION, CREATE SEPARATE AIRLINE DHR EVEN IF AIRFARE ON PMT DHR IS SET TO YES
IF '$DATA(ACRCANCL)
IF $GET(ACRADA)
IF ACRREFX=600
IF $PIECE(^ACRSYS(ACRADA,"DT"),U,34)
QUIT
+6 SET ACR3=ACR3-$GET(ACRALTOT)
+7 IF $GET(ACRALTOT)
IF $GET(ACRREFA)]""
SET ACROBJ(ACRACT,ACR2,ACR1,"A")=ACRALTOT
+8 QUIT
ACT ;WRITE ACCOUNTING INFO
+1 WRITE !
+2 DO B
+3 ;W:+$G(ACRPSC)'=26&($G(ACRPSC)'=33) ?2 ;ACR*2.1*3.40
+4 ;W:+$G(ACRPSC)=26!(+$G(ACRPSC)=33) ?41 ;ACR*2.1*3.40
+5 ;ACR*2.1*3.40
IF +$GET(ACRPSC)'=26&($GET(ACRPSC)'=33)
WRITE ?0
+6 ;ACR*2.1*3.40
IF +$GET(ACRPSC)=26!(+$GET(ACRPSC)=33)
WRITE ?38
+7 WRITE ACRACT
+8 ;ACR*2.1*3.40
IF ACRREFX=103&'$DATA(ACR3542)&'$DATA(ACRORIGF)
WRITE ?39,"|11. BUSINESS CLASSIFICATION"
+9 IF ACRREFX=130
IF $GET(ACRALTOT)
WRITE ?45,"(AIRLINE EXPENSE: ",$FNUMBER(ACRALTOT,"P,",2),")"
+10 WRITE ?79
+11 DO B
+12 QUIT
SETACT ;EP;TO SET ACCOUNTING DATA
+1 SET ACRDPT=$PIECE(^ACRLOCB(ACRLBDA,0),U,5)
+2 SET ACRDT=^ACRLOCB(ACRLBDA,"DT")
+3 NEW ACRPJNUM
+4 SET ACRPJNUM=$PIECE($GET(^ACRLOCB(ACRLBDA,3)),U)
+5 SET ACRFY=$PIECE(ACRDT,U)
+6 SET ACRAPPDA=$PIECE(ACRDT,U,4)
+7 SET ACRALWDA=$PIECE(ACRDT,U,5)
+8 SET ACRSSADA=$PIECE(ACRDT,U,8)
+9 SET (ACRCAN,ACRCANDA)=$PIECE(ACRDT,U,9)
+10 SET ACRLCOD=$PIECE(ACRDT,U,11)
+11 SET ACRCCTDA=$PIECE(ACRDT,U,15)
+12 SET ACRDPT=$PIECE(^AUTTPRG(ACRDPT,0),U,6)
+13 KILL ACRCCT
+14 IF ACRCCTDA
IF $DATA(^AUTTCCT(ACRCCTDA,0))
SET ACRCCT=$PIECE(^(0),U)
+15 IF '$DATA(ACRCCT)
IF ACRCANDA
IF $DATA(^AUTTCAN(ACRCANDA,0))
SET ACRCCT=$EXTRACT($PIECE(^(0),U),6,7)
+16 SET ACRAPP=$PIECE(^AUTTPRO(ACRAPPDA,0),U)
+17 SET ACRALW=$PIECE(^AUTTALLW(ACRALWDA,0),U)
+18 SET ACRSSA=$PIECE(^AUTTSSA(ACRSSADA,0),U,3)
+19 SET ACRLCOD=$EXTRACT($PIECE(^AUTTLCOD(ACRLCOD,0),U),2,3)_"."_$PIECE($GET(^AUTTLCOD(ACRLCOD,"DT")),U,2)
+20 ;ACR*2.1*3.40
SET ACRACT=ACRAPP_" "_ACRFY_"-"_ACRALW_"."_ACRSSA_"."_($SELECT(ACRPJNUM]"":ACRPJNUM,1:(ACRDPT_ACRCCT)))_"."_ACRLCOD
+21 QUIT
