ACRFDHR ;IHS/OIRM/DSD/THL,AEF - PROCESS DOCUMENT HISTORY RECORDS; [ 10/27/2004 4:18 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**3,13**;NOV 05, 2001
;
EN D EN1
EXIT F ACRI=1:1:30 K @("ACR"_ACRI)
K ACR,ACRTCODE,ACRRCODE,ACRMCODE
Q
EN1 ;
N ACRREF,ACRDHR,ACRREFX,ACROBJ
S ACRDOC0=^ACRDOC(ACRDOCDA,0)
S ACRREF=$P(ACRDOC0,U,13)
I $P(ACRDOC0,U,4)=30 S ACRREF=63
I $P(ACRDOC0,U,4)=35,$P($G(^ACRSYS(1,"DT1")),U,8)'=1 Q ; NO DHR FOR CREDIT CARD PURCHASES
I $P(ACRDOC0,U,19),'$P(^ACRSYS(1,"DT"),U,36) Q ;NO DHR FOR BPA CALLS UNLESS INDICATED
Q:'ACRREF
Q:'$D(^AUTTDOCR(ACRREF,0)) S ACRREF=$P(^AUTTDOCR(ACRREF,0),U)
Q:ACRREF=""
I $D(^ACRDOC(ACRDOCDA,3)),$P(^(3),U,11)]""!($P(^(3),U,12)]"") S ACRREF=210
S ACRREFX=$S("^103^210^101^"[(U_ACRREF_U):103,1:ACRREF)
I $D(ACRDHRZ),$D(ACRRREF) S ACRREF=ACRRREF
I $D(ACRRR),$G(ACRRRNO) S ACRREFX=499
S ACRDHR=""
I $P(^ACRSYS(1,"DT"),U,32),"^130^600^"'[(U_ACRREF_U) Q
I ACRREF=210,'$P(^ACRSYS(1,"DT"),U,38) Q
S:'$D(ACRTCODE) ACR3=$S(ACRREF'=600:"050",$P(^ACROBL(ACRDOCDA,"APV"),U,9)>1:"182",1:"192")
S:$D(ACRTCODE)#2 ACR3=ACRTCODE
I $P(^ACRSYS(1,"DT"),U,37),"^600^618^"[(U_ACRREF_U),"^181^182^191^192^"[(U_$G(ACRTCODE)_U) Q
I "^600^618^"[(U_ACRREF_U),$P(^ACRSYS(1,"DT"),U,37),'$D(ACRCANCL) Q ;NO DHR IF TRAVEL PAID BY 1166
D EN1^ACRFPSS
D DHR
Q
DHR ;EP;CREATE INDIVIDUAL DHR'S
S ACR1=2
S:"^116^204^103^204^349^326^210^"[(U_ACRREF_U) ACRVDA=$P(^ACRDOC(ACRDOCDA,"PO"),U,5)
S:"^130^600^"[(U_ACRREF_U) ACRVDA=$P(^ACRDOC(ACRDOCDA,"TO"),U,9)
S:ACRREF="043" ACRVDA=""
S:ACRREF=148 ACRVDA=+$G(^ACRDOC(ACRDOCDA,"TRNG3"))
S ACR2=DT
S:'$D(ACRTCODE) ACR3=$S(ACRREF'=600:"050",$P(^ACROBL(ACRDOCDA,"APV"),U,9)>1:"182",1:"192")
S:$D(ACRTCODE)#2 ACR3=ACRTCODE
S:'$D(ACRRCODE)#2 ACR4=$S($P(ACRDOC0,U,14)["CANCELLED":2,1:1)
S:$D(ACRRCODE)#2 ACR4=ACRRCODE
N ACRRCODT ;ACR*2.1*3.3
S ACRRCODT=ACR4 ;SAVE REVERSAL CODE ;ACR*2.1*3.3
S:'$D(ACRMCODE) ACR5=$S($P(ACRDOC0,U,15):5,$D(^ACRDHR("E",ACRDOCDA))&(ACRREF=600):4,$P(ACRDOC0,U,14)["CANCELLED":5,1:3)
S:$D(ACRMCODE)#2 ACR5=ACRMCODE
S ACR6=$S(ACRREF'=600:ACRREF,ACRREF=600:130,1:ACRREF)
N ACRDOC,ACRCAN,ACRAMT
S ACR7=$S("^103^349^326^210^"[(U_ACRREF_U)&($P(ACRDOC0,U,2)]""):$P(ACRDOC0,U,2),1:$P(ACRDOC0,U))
S:$L($P(ACRDOC0,U,27))=10 ACR7=$P(ACRDOC0,U,27)
I ACR7["-" D
.S ACR7=$TR(ACR7,"-","")
.S ACR7=$E(ACR7,2,11)
;S:"^103^349^326^130^"[(U_$E(ACR7,1,3)_U) ACR7=$E(ACR7,4,99)
S ACR7=$E("0000000000",1,10-$L(ACR7))_ACR7
S ACR7=$E(ACR7,1,10)
I ACRREFX'=499,ACRREFX'="043" S ACR8=$S($P($G(^ACRDOC(ACRDOCDA,18)),U,5)]"":$P(^AUTTDOCR($P(^(18),U,5),0),U),1:"000")
I ACRREFX=499!(ACRREFX="043") D
.S ACR8=ACR6
.S ACR9=ACR7
.S:ACRREFX="043" (ACR6,ACR7)=""
I ACRREFX'=499&(ACRREFX'="043") D
.S ACR9=$P($G(^ACRDOC(ACRDOCDA,18)),U,4)
.S ACR9=$E("0000000000",1,10-$L(ACR9))_ACR9
S ACR10=1
N ACRLOCB ; ACR*2.1*13.05 IM10810
S ACRLOCB=$P(ACRDOC0,U,6) ; ACR*2.1*13.05 IM10810
S ACR11=$E($$FYFUN^ACRFUTL1(ACRLOCB),4) ; ACR*2.1*13.05 IM10810
S ACR15=$S($G(ACRFEDC)=2:2,ACRREF'=210:1,1:2)
S ACR16=""
I ACRVDA D
.I "^103^349^326^210^148^204^"[(U_ACRREF_U),$D(^AUTTVNDR(ACRVDA,11)),$P(^(11),U,13)]"" S ACR16=$P(^(11),U,13)
.I "^130^600^"[(U_ACRREF_U),$D(^VA(200,ACRVDA,1)),$P(^(1),U,9)]"" S ACR16=$P(^(1),U,9)
S ACR16=ACR16_$E(" ",1,15-$L(ACR16))
S ACR17="000000000000000"
S ACR18=$E($P($G(^ACRDOC(+$G(ACRDOCDA),18)),U,3),1,10)
S ACR18=$$PAD^ACRFUTL(ACR18,"L",10,"")
S ACR19="000000"
S ACR20="00"
S ACR21="0"
S ACR22="00"
S ACR23="0000"
S ACR24="0000"
S ACR25="000000"
S ACR27=""
I $G(ACRDOCDA)]"" S ACR27=$G(^ACRDOC(ACRDOCDA,"TO"))
S ACR26=$E($P(ACR27,U,14),4,5)_$E($P(ACR27,U,14),2,3)
I $L(ACR26)'=4 S ACR26=" "
S ACR27=$E($P(ACR27,U,15),4,5)_$E($P(ACR27,U,15),2,3)
I $L(ACR27)'=4 S ACR27=" "
S ACR28=$E($$FYFUN^ACRFUTL1(ACRLOCB),3,4) ; ACR*2.1*13.05 IM10810
I $L(ACR28)'=2 S ACR28=" "
S ACR29=" "
S ACR30=" "
S ACRACT=""
F S ACRACT=$O(ACROBJ(ACRACT)) Q:ACRACT="" D ACT
Q
;
ACT ;S ACR11=$E($P(ACRACT," ",2)); ; ACR*2.1*13.05 IM10810
S ACRCANDA=0
F S ACRCANDA=$O(ACROBJ(ACRACT,ACRCANDA)) Q:'ACRCANDA I $D(^AUTTCAN(ACRCANDA,0)) S ACR12=$P(^(0),U) D:$L(ACR12)=7
.S ACROBJDA=0
.F S ACROBJDA=$O(ACROBJ(ACRACT,ACRCANDA,ACROBJDA)) Q:'ACROBJDA I $D(^AUTTOBJC(ACROBJDA,0)) S ACR13=$P(^(0),U) I $L(ACR13)=4 D
..D CREATE
..;NEXT SECTION CREATES SEPARATE DHR FOR AIRLINE EXPENSE IF INDICATED
..I $D(ACROBJ(ACRACT,ACRCANDA,ACROBJDA,"A"))#2 D
...S ACR13=$P(^AUTTOBJC(ACROBJDA,0),U)
...S ACR6=$P($G(^AUTTDOCR(+$P($G(^ACRSYS(ACRADA,"DT")),U,35),0)),U)
...Q:ACR6'?3N
...S ACROBJ(ACRACT,ACRCANDA,ACROBJDA)=ACROBJ(ACRACT,ACRCANDA,ACROBJDA,"A")
...D CREATE
K ACRDR
Q
CREATE I ACRREFX=499,$E(ACR13,1,2)=22!($E(ACR13,1,2)=23) Q
S ACR14=ACROBJ(ACRACT,ACRCANDA,ACROBJDA)
I +ACR14=0,"^181^182^190^191^192^"'[(U_(ACR3)_U) Q
I ACRREF=600,'$D(^ACRDHR("E",ACRDOCDA)),ACR14=0 Q
I ACR3="050",ACROBJDA=$P($G(^ACRSYS(1,400)),U,2),'$P($G(^ACRSYS(1,400)),U,3) Q ;TRAVEL MGT FEE OBL DHR
I "^181^182^190^191^191^"[(U_(ACR3)_U),ACROBJDA=$P($G(^ACRSYS(1,400)),U,2),'$P($G(^ACRSYS(1,400)),U,4) Q ;TRAVEL MGT FEE PMT DHR
D 14
S (ACRDR,ACRDHR)=""
F ACR=1:1:30 D
.S ACRDR=ACRDR_ACR_"////"_@("ACR"_ACR)_";"
.S ACRDHR=ACRDHR_@("ACR"_ACR)
S ACRDR=ACRDR_"211////"_$G(ACRRRZDA) ;ACR*2.1*3.31
;Q:$D(^ACRDHR("C",ACRDHR)) ;COMMENTED OUT TO ALLOW NEW OBLIGATION DHR TO BE CREATED WHEN A DOCUMENT IS CANCELLED AND THEN RETURNED TO INITIATOR AND REPROCESSED
S X=ACR7
S:ACRREF="043" X=ACR9
S DIC="^ACRDHR("
S DIC(0)="L"
S DLAYGO=9002189.1
S DIC("DR")=".02////"_DT_";.03////"_DUZ_";.04////"_$G(ACRDOCDA)
K DD,DO,DINUM
D FILE^ACRFDIC
S (ACRDA,DA)=+Y
I +Y>0 S ACRFMS=+Y
S DIE="^ACRDHR("
S DR=ACRDR
D DIE^ACRFDIC
S DA=ACRDA
S DIE="^ACRDHR("
S DR="99////"_ACRDHR
D DIE^ACRFDIC
D DHRRCD^ACRFDHR1
I $G(ACRDOCDA) D ;ACR*2.1*3.28
.S ACR=ACR1_U_ACR3_U_ACR4_U_ACR5_U_ACR6_U_ACR12_U_ACR13_U_$$DOL^ACRFUTL(ACR14/100)_U_ACR15_U_ACR16_U_ACR7 ;OPEN DOCUMENT INTERFACE ;ACR*2.1*3.28
.D EN^ACRFODOC(ACRDOCDA,ACR,"") ;OPEN DOCUMENT INTERFACE ;ACR*2.1*3.28
S (ACRRCODE,ACR4)=ACRRCODT ;RESET REVERSAL CODE ;ACR*2.1*3.3
Q
14 ;FORMAT DOLLAR AMOUNT
S ACR14=$FN(ACR14,"P",2)
S ACR14=$TR(ACR14," ","")
S ACR14=$TR(ACR14,".","")
I ACR14["(" D ;ACR*2.1*3.3
.I ACRRCODT=2 S (ACRRCODE,ACR4)=1 ;If cancelled reverse negative to positive ;ACR*2.1*3.3
.I ACRRCODT=1 S (ACRRCODE,ACR4)=2 ;ACR*2.1*3.3
S ACR14=$TR(ACR14,"(",0)
S ACR14=$TR(ACR14,")","")
S ACR14=$J(ACR14,12)
S ACR14=$TR(ACR14," ","0")
Q
PRINT ;EP;TO PRINT DHR'S FOR SELECTED DOCUMENT
Q:'$D(ACRDOCDA)
Q:'ACRDOCDA
N ACRACT
S ACRDOC0=^ACRDOC(ACRDOCDA,0),ACRACT=$P(^ACRSYS(1,"DT"),U,25)
I $P(ACRDOC0,U,4)=35,$P($G(^ACRSYS(1,"DT1")),U,8)'=1 Q ; NO DHR FOR CREDIT CARD PURCHASES
I 'ACRACT!$P($G(^ACRSYS(1,"DT")),U,39) D P Q
;PRINT DHR FOR BPA CALLS IF NO AUTO DHR
I $P(ACRDOC0,U,19),'$P(^ACRSYS(1,"DT"),U,36) D P Q
;PRINT NON-TO/TV DHR'S
I $P(^ACRSYS(1,"DT"),U,32),"^130^600^"'[(U_ACRREF_U) D P Q
I ACRREF=210,'$P(^ACRSYS(1,"DT"),U,38) D P Q
;NO DHR IF TRAVEL PAID BY 1166
I "^600^618^"[(U_ACRREF_U),$P(^ACRSYS(1,"DT"),U,37) D P Q
Q
P S D0=0
F S D0=$O(^ACRDHR("E",ACRDOCDA,D0)) Q:'D0 D P1
D PAUSE^ACRFWARN
Q
P1 ;EP;TO PRINT INDIVIDUAL DHR
N DXS,DIP,DC,DN
W !,"DOCUMENT HISTORY RECORD"
W:$G(ACRDOCDA) " FOR: ",$P(^ACRDOC(ACRDOCDA,0),U,2)
D ^ACRDHR
W @IOF
Q
ACRFDHR ;IHS/OIRM/DSD/THL,AEF - PROCESS DOCUMENT HISTORY RECORDS; [ 10/27/2004 4:18 PM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**3,13**;NOV 05, 2001
+2 ;
EN DO EN1
EXIT FOR ACRI=1:1:30
KILL @("ACR"_ACRI)
+1 KILL ACR,ACRTCODE,ACRRCODE,ACRMCODE
+2 QUIT
EN1 ;
+1 NEW ACRREF,ACRDHR,ACRREFX,ACROBJ
+2 SET ACRDOC0=^ACRDOC(ACRDOCDA,0)
+3 SET ACRREF=$PIECE(ACRDOC0,U,13)
+4 IF $PIECE(ACRDOC0,U,4)=30
SET ACRREF=63
+5 ; NO DHR FOR CREDIT CARD PURCHASES
IF $PIECE(ACRDOC0,U,4)=35
IF $PIECE($GET(^ACRSYS(1,"DT1")),U,8)'=1
QUIT
+6 ;NO DHR FOR BPA CALLS UNLESS INDICATED
IF $PIECE(ACRDOC0,U,19)
IF '$PIECE(^ACRSYS(1,"DT"),U,36)
QUIT
+7 IF 'ACRREF
QUIT
+8 IF '$DATA(^AUTTDOCR(ACRREF,0))
QUIT
SET ACRREF=$PIECE(^AUTTDOCR(ACRREF,0),U)
+9 IF ACRREF=""
QUIT
+10 IF $DATA(^ACRDOC(ACRDOCDA,3))
IF $PIECE(^(3),U,11)]""!($PIECE(^(3),U,12)]"")
SET ACRREF=210
+11 SET ACRREFX=$SELECT("^103^210^101^"[(U_ACRREF_U):103,1:ACRREF)
+12 IF $DATA(ACRDHRZ)
IF $DATA(ACRRREF)
SET ACRREF=ACRRREF
+13 IF $DATA(ACRRR)
IF $GET(ACRRRNO)
SET ACRREFX=499
+14 SET ACRDHR=""
+15 IF $PIECE(^ACRSYS(1,"DT"),U,32)
IF "^130^600^"'[(U_ACRREF_U)
QUIT
+16 IF ACRREF=210
IF '$PIECE(^ACRSYS(1,"DT"),U,38)
QUIT
+17 IF '$DATA(ACRTCODE)
SET ACR3=$SELECT(ACRREF'=600:"050",$PIECE(^ACROBL(ACRDOCDA,"APV"),U,9)>1:"182",1:"192")
+18 IF $DATA(ACRTCODE)#2
SET ACR3=ACRTCODE
+19 IF $PIECE(^ACRSYS(1,"DT"),U,37)
IF "^600^618^"[(U_ACRREF_U)
IF "^181^182^191^192^"[(U_$GET(ACRTCODE)_U)
QUIT
+20 ;NO DHR IF TRAVEL PAID BY 1166
IF "^600^618^"[(U_ACRREF_U)
IF $PIECE(^ACRSYS(1,"DT"),U,37)
IF '$DATA(ACRCANCL)
QUIT
+21 DO EN1^ACRFPSS
+22 DO DHR
+23 QUIT
DHR ;EP;CREATE INDIVIDUAL DHR'S
+1 SET ACR1=2
+2 IF "^116^204^103^204^349^326^210^"[(U_ACRREF_U)
SET ACRVDA=$PIECE(^ACRDOC(ACRDOCDA,"PO"),U,5)
+3 IF "^130^600^"[(U_ACRREF_U)
SET ACRVDA=$PIECE(^ACRDOC(ACRDOCDA,"TO"),U,9)
+4 IF ACRREF="043"
SET ACRVDA=""
+5 IF ACRREF=148
SET ACRVDA=+$GET(^ACRDOC(ACRDOCDA,"TRNG3"))
+6 SET ACR2=DT
+7 IF '$DATA(ACRTCODE)
SET ACR3=$SELECT(ACRREF'=600:"050",$PIECE(^ACROBL(ACRDOCDA,"APV"),U,9)>1:"182",1:"192")
+8 IF $DATA(ACRTCODE)#2
SET ACR3=ACRTCODE
+9 IF '$DATA(ACRRCODE)#2
SET ACR4=$SELECT($PIECE(ACRDOC0,U,14)["CANCELLED":2,1:1)
+10 IF $DATA(ACRRCODE)#2
SET ACR4=ACRRCODE
+11 ;ACR*2.1*3.3
NEW ACRRCODT
+12 ;SAVE REVERSAL CODE ;ACR*2.1*3.3
SET ACRRCODT=ACR4
+13 IF '$DATA(ACRMCODE)
SET ACR5=$SELECT($PIECE(ACRDOC0,U,15):5,$DATA(^ACRDHR("E",ACRDOCDA))&(ACRREF=600):4,$PIECE(ACRDOC0,U,14)["CANCELLED":5,1:3)
+14 IF $DATA(ACRMCODE)#2
SET ACR5=ACRMCODE
+15 SET ACR6=$SELECT(ACRREF'=600:ACRREF,ACRREF=600:130,1:ACRREF)
+16 NEW ACRDOC,ACRCAN,ACRAMT
+17 SET ACR7=$SELECT("^103^349^326^210^"[(U_ACRREF_U)&($PIECE(ACRDOC0,U,2)]""):$PIECE(ACRDOC0,U,2),1:$PIECE(ACRDOC0,U))
+18 IF $LENGTH($PIECE(ACRDOC0,U,27))=10
SET ACR7=$PIECE(ACRDOC0,U,27)
+19 IF ACR7["-"
Begin DoDot:1
+20 SET ACR7=$TRANSLATE(ACR7,"-","")
+21 SET ACR7=$EXTRACT(ACR7,2,11)
End DoDot:1
+22 ;S:"^103^349^326^130^"[(U_$E(ACR7,1,3)_U) ACR7=$E(ACR7,4,99)
+23 SET ACR7=$EXTRACT("0000000000",1,10-$LENGTH(ACR7))_ACR7
+24 SET ACR7=$EXTRACT(ACR7,1,10)
+25 IF ACRREFX'=499
IF ACRREFX'="043"
SET ACR8=$SELECT($PIECE($GET(^ACRDOC(ACRDOCDA,18)),U,5)]"":$PIECE(^AUTTDOCR($PIECE(^(18),U,5),0),U),1:"000")
+26 IF ACRREFX=499!(ACRREFX="043")
Begin DoDot:1
+27 SET ACR8=ACR6
+28 SET ACR9=ACR7
+29 IF ACRREFX="043"
SET (ACR6,ACR7)=""
End DoDot:1
+30 IF ACRREFX'=499&(ACRREFX'="043")
Begin DoDot:1
+31 SET ACR9=$PIECE($GET(^ACRDOC(ACRDOCDA,18)),U,4)
+32 SET ACR9=$EXTRACT("0000000000",1,10-$LENGTH(ACR9))_ACR9
End DoDot:1
+33 SET ACR10=1
+34 ; ACR*2.1*13.05 IM10810
NEW ACRLOCB
+35 ; ACR*2.1*13.05 IM10810
SET ACRLOCB=$PIECE(ACRDOC0,U,6)
+36 ; ACR*2.1*13.05 IM10810
SET ACR11=$EXTRACT($$FYFUN^ACRFUTL1(ACRLOCB),4)
+37 SET ACR15=$SELECT($GET(ACRFEDC)=2:2,ACRREF'=210:1,1:2)
+38 SET ACR16=""
+39 IF ACRVDA
Begin DoDot:1
+40 IF "^103^349^326^210^148^204^"[(U_ACRREF_U)
IF $DATA(^AUTTVNDR(ACRVDA,11))
IF $PIECE(^(11),U,13)]""
SET ACR16=$PIECE(^(11),U,13)
+41 IF "^130^600^"[(U_ACRREF_U)
IF $DATA(^VA(200,ACRVDA,1))
IF $PIECE(^(1),U,9)]""
SET ACR16=$PIECE(^(1),U,9)
End DoDot:1
+42 SET ACR16=ACR16_$EXTRACT(" ",1,15-$LENGTH(ACR16))
+43 SET ACR17="000000000000000"
+44 SET ACR18=$EXTRACT($PIECE($GET(^ACRDOC(+$GET(ACRDOCDA),18)),U,3),1,10)
+45 SET ACR18=$$PAD^ACRFUTL(ACR18,"L",10,"")
+46 SET ACR19="000000"
+47 SET ACR20="00"
+48 SET ACR21="0"
+49 SET ACR22="00"
+50 SET ACR23="0000"
+51 SET ACR24="0000"
+52 SET ACR25="000000"
+53 SET ACR27=""
+54 IF $GET(ACRDOCDA)]""
SET ACR27=$GET(^ACRDOC(ACRDOCDA,"TO"))
+55 SET ACR26=$EXTRACT($PIECE(ACR27,U,14),4,5)_$EXTRACT($PIECE(ACR27,U,14),2,3)
+56 IF $LENGTH(ACR26)'=4
SET ACR26=" "
+57 SET ACR27=$EXTRACT($PIECE(ACR27,U,15),4,5)_$EXTRACT($PIECE(ACR27,U,15),2,3)
+58 IF $LENGTH(ACR27)'=4
SET ACR27=" "
+59 ; ACR*2.1*13.05 IM10810
SET ACR28=$EXTRACT($$FYFUN^ACRFUTL1(ACRLOCB),3,4)
+60 IF $LENGTH(ACR28)'=2
SET ACR28=" "
+61 SET ACR29=" "
+62 SET ACR30=" "
+63 SET ACRACT=""
+64 FOR
SET ACRACT=$ORDER(ACROBJ(ACRACT))
IF ACRACT=""
QUIT
DO ACT
+65 QUIT
+66 ;
ACT ;S ACR11=$E($P(ACRACT," ",2)); ; ACR*2.1*13.05 IM10810
+1 SET ACRCANDA=0
+2 FOR
SET ACRCANDA=$ORDER(ACROBJ(ACRACT,ACRCANDA))
IF 'ACRCANDA
QUIT
IF $DATA(^AUTTCAN(ACRCANDA,0))
SET ACR12=$PIECE(^(0),U)
IF $LENGTH(ACR12)=7
Begin DoDot:1
+3 SET ACROBJDA=0
+4 FOR
SET ACROBJDA=$ORDER(ACROBJ(ACRACT,ACRCANDA,ACROBJDA))
IF 'ACROBJDA
QUIT
IF $DATA(^AUTTOBJC(ACROBJDA,0))
SET ACR13=$PIECE(^(0),U)
IF $LENGTH(ACR13)=4
Begin DoDot:2
+5 DO CREATE
+6 ;NEXT SECTION CREATES SEPARATE DHR FOR AIRLINE EXPENSE IF INDICATED
+7 IF $DATA(ACROBJ(ACRACT,ACRCANDA,ACROBJDA,"A"))#2
Begin DoDot:3
+8 SET ACR13=$PIECE(^AUTTOBJC(ACROBJDA,0),U)
+9 SET ACR6=$PIECE($GET(^AUTTDOCR(+$PIECE($GET(^ACRSYS(ACRADA,"DT")),U,35),0)),U)
+10 IF ACR6'?3N
QUIT
+11 SET ACROBJ(ACRACT,ACRCANDA,ACROBJDA)=ACROBJ(ACRACT,ACRCANDA,ACROBJDA,"A")
+12 DO CREATE
End DoDot:3
End DoDot:2
End DoDot:1
+13 KILL ACRDR
+14 QUIT
CREATE IF ACRREFX=499
IF $EXTRACT(ACR13,1,2)=22!($EXTRACT(ACR13,1,2)=23)
QUIT
+1 SET ACR14=ACROBJ(ACRACT,ACRCANDA,ACROBJDA)
+2 IF +ACR14=0
IF "^181^182^190^191^192^"'[(U_(ACR3)_U)
QUIT
+3 IF ACRREF=600
IF '$DATA(^ACRDHR("E",ACRDOCDA))
IF ACR14=0
QUIT
+4 ;TRAVEL MGT FEE OBL DHR
IF ACR3="050"
IF ACROBJDA=$PIECE($GET(^ACRSYS(1,400)),U,2)
IF '$PIECE($GET(^ACRSYS(1,400)),U,3)
QUIT
+5 ;TRAVEL MGT FEE PMT DHR
IF "^181^182^190^191^191^"[(U_(ACR3)_U)
IF ACROBJDA=$PIECE($GET(^ACRSYS(1,400)),U,2)
IF '$PIECE($GET(^ACRSYS(1,400)),U,4)
QUIT
+6 DO 14
+7 SET (ACRDR,ACRDHR)=""
+8 FOR ACR=1:1:30
Begin DoDot:1
+9 SET ACRDR=ACRDR_ACR_"////"_@("ACR"_ACR)_";"
+10 SET ACRDHR=ACRDHR_@("ACR"_ACR)
End DoDot:1
+11 ;ACR*2.1*3.31
SET ACRDR=ACRDR_"211////"_$GET(ACRRRZDA)
+12 ;Q:$D(^ACRDHR("C",ACRDHR)) ;COMMENTED OUT TO ALLOW NEW OBLIGATION DHR TO BE CREATED WHEN A DOCUMENT IS CANCELLED AND THEN RETURNED TO INITIATOR AND REPROCESSED
+13 SET X=ACR7
+14 IF ACRREF="043"
SET X=ACR9
+15 SET DIC="^ACRDHR("
+16 SET DIC(0)="L"
+17 SET DLAYGO=9002189.1
+18 SET DIC("DR")=".02////"_DT_";.03////"_DUZ_";.04////"_$GET(ACRDOCDA)
+19 KILL DD,DO,DINUM
+20 DO FILE^ACRFDIC
+21 SET (ACRDA,DA)=+Y
+22 IF +Y>0
SET ACRFMS=+Y
+23 SET DIE="^ACRDHR("
+24 SET DR=ACRDR
+25 DO DIE^ACRFDIC
+26 SET DA=ACRDA
+27 SET DIE="^ACRDHR("
+28 SET DR="99////"_ACRDHR
+29 DO DIE^ACRFDIC
+30 DO DHRRCD^ACRFDHR1
+31 ;ACR*2.1*3.28
IF $GET(ACRDOCDA)
Begin DoDot:1
+32 ;OPEN DOCUMENT INTERFACE ;ACR*2.1*3.28
SET ACR=ACR1_U_ACR3_U_ACR4_U_ACR5_U_ACR6_U_ACR12_U_ACR13_U_$$DOL^ACRFUTL(ACR14/100)_U_ACR15_U_ACR16_U_ACR7
+33 ;OPEN DOCUMENT INTERFACE ;ACR*2.1*3.28
DO EN^ACRFODOC(ACRDOCDA,ACR,"")
End DoDot:1
+34 ;RESET REVERSAL CODE ;ACR*2.1*3.3
SET (ACRRCODE,ACR4)=ACRRCODT
+35 QUIT
14 ;FORMAT DOLLAR AMOUNT
+1 SET ACR14=$FNUMBER(ACR14,"P",2)
+2 SET ACR14=$TRANSLATE(ACR14," ","")
+3 SET ACR14=$TRANSLATE(ACR14,".","")
+4 ;ACR*2.1*3.3
IF ACR14["("
Begin DoDot:1
+5 ;If cancelled reverse negative to positive ;ACR*2.1*3.3
IF ACRRCODT=2
SET (ACRRCODE,ACR4)=1
+6 ;ACR*2.1*3.3
IF ACRRCODT=1
SET (ACRRCODE,ACR4)=2
End DoDot:1
+7 SET ACR14=$TRANSLATE(ACR14,"(",0)
+8 SET ACR14=$TRANSLATE(ACR14,")","")
+9 SET ACR14=$JUSTIFY(ACR14,12)
+10 SET ACR14=$TRANSLATE(ACR14," ","0")
+11 QUIT
PRINT ;EP;TO PRINT DHR'S FOR SELECTED DOCUMENT
+1 IF '$DATA(ACRDOCDA)
QUIT
+2 IF 'ACRDOCDA
QUIT
+3 NEW ACRACT
+4 SET ACRDOC0=^ACRDOC(ACRDOCDA,0)
SET ACRACT=$PIECE(^ACRSYS(1,"DT"),U,25)
+5 ; NO DHR FOR CREDIT CARD PURCHASES
IF $PIECE(ACRDOC0,U,4)=35
IF $PIECE($GET(^ACRSYS(1,"DT1")),U,8)'=1
QUIT
+6 IF 'ACRACT!$PIECE($GET(^ACRSYS(1,"DT")),U,39)
DO P
QUIT
+7 ;PRINT DHR FOR BPA CALLS IF NO AUTO DHR
+8 IF $PIECE(ACRDOC0,U,19)
IF '$PIECE(^ACRSYS(1,"DT"),U,36)
DO P
QUIT
+9 ;PRINT NON-TO/TV DHR'S
+10 IF $PIECE(^ACRSYS(1,"DT"),U,32)
IF "^130^600^"'[(U_ACRREF_U)
DO P
QUIT
+11 IF ACRREF=210
IF '$PIECE(^ACRSYS(1,"DT"),U,38)
DO P
QUIT
+12 ;NO DHR IF TRAVEL PAID BY 1166
+13 IF "^600^618^"[(U_ACRREF_U)
IF $PIECE(^ACRSYS(1,"DT"),U,37)
DO P
QUIT
+14 QUIT
P SET D0=0
+1 FOR
SET D0=$ORDER(^ACRDHR("E",ACRDOCDA,D0))
IF 'D0
QUIT
DO P1
+2 DO PAUSE^ACRFWARN
+3 QUIT
P1 ;EP;TO PRINT INDIVIDUAL DHR
+1 NEW DXS,DIP,DC,DN
+2 WRITE !,"DOCUMENT HISTORY RECORD"
+3 IF $GET(ACRDOCDA)
WRITE " FOR: ",$PIECE(^ACRDOC(ACRDOCDA,0),U,2)
+4 DO ^ACRDHR
+5 WRITE @IOF
+6 QUIT
