- 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