- 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
