- ACRFDHR1 ;IHS/OIRM/DSD/THL,AEF - PROCESS DOCUMENT HISTORY RECORDS - CON'T; [ 02/02/2005 10:25 AM ]
- ;;2.1;ADMIN RESOURCE MGT SYSTEM;**3,16**;NOV 05, 2001
- ;;
- DHRRCD ;EP;TO CREATE DHR RECORD IN DHR PROGRAM
- ; Quit if hold for next fiscal year
- Q:$$HOLD($G(ACRFY),$G(ACR3),$G(ACRD0),$G(ACRD1),$G(ACRD2)) ;ACR*2.1*3.08
- ;
- ; Quit if not 'activate DHR interface'
- Q:$P(^ACRSYS($$SYS^ACRFUTL($P($G(ACRDOC0),U,8)),"DT"),U,25)'=1
- ;
- ; Quit if no DHR records
- Q:'$D(^AFSHRCDS(0))#2
- ;
- ; Quit if Travel DHR only, and reference code is not 130 or 600 (travel order or voucher)
- I $P(^ACRSYS($$SYS^ACRFUTL($P($G(ACRDOC0),U,8)),"DT"),U,32),"^130^600^"'[(U_ACRREF_U) Q
- ;
- ; Quit if multi-use standard re and not 'create DHR for Fedstrip'
- I ACRREF=210,'$P(^ACRSYS($$SYS^ACRFUTL($P($G(ACRDOC0),U,8)),"DT"),U,38) Q
- ;
- ;I $P(^ACRSYS(1,"DT"),U,37),"^600^618^"[(U_ACRREF_U),"^181^182^191^192^281^"[(U_(ACR3)_U) Q
- N ACRDATE,ACRDA
- S ACRDATE=DT
- S ACRDA=$S($G(ACRIV)'="PAY":5,1:6)
- DATE I $P($G(^AFSHRCDS(ACRDA,"D",ACRDATE,"I",1,0)),U,3)="C" D G DATE
- .S X1=ACRDATE
- .S X2=1
- .D C^%DTC
- .S ACRDATE=X
- I '$D(^AFSHRCDS(ACRDA,0))#2 D
- .S (X,DINUM)=ACRDA
- .S DIC="^AFSHRCDS("
- .S DIC(0)="L"
- .D FILE^ACRFDIC
- S:$D(ACRDHRZ) ACRDATE=ACRDHRZ
- S:'$D(^AFSHRCDS(ACRDA,"D",0)) ^AFSHRCDS(ACRDA,"D",0)="^9002322.02D"
- I $G(ACRIV)'="PAY",ACRREF'="043" D I 1
- .S ACRACPT=$P(ACRDOC0,U,8)
- .S ACRACPT=$P(^ACRPO(ACRACPT,0),U,4)
- .I ACRACPT,$D(^AUTTACPT(ACRACPT,0)) S ACRACPT=$P(^AUTTACPT(ACRACPT,0),U)
- I $D(^AFSHRCDS(ACRDA,"D",ACRDATE,0))#2 S Y=ACRDATE
- E D
- .S DA(1)=ACRDA
- .S (X,DINUM)=ACRDATE
- .S DIC="^AFSHRCDS("_ACRDA_",""D"","
- .S DIC(0)="L"
- .D FILE^ACRFDIC
- S ACRDA(2)=+Y
- S:'$D(^AFSHRCDS(ACRDA,"D",ACRDA(2),"I",0))#2 ^AFSHRCDS(ACRDA,"D",ACRDA(2),"I",0)="^9002322.21"
- I $D(^AFSHRCDS(ACRDA,"D",ACRDA(2),"I","B","R")) S Y=$O(^("R",0))
- E D
- .S DA(2)=ACRDA
- .S DA(1)=ACRDA(2)
- .S X="R"
- .S DIC="^AFSHRCDS("_ACRDA_",""D"","_ACRDA(2)_",""I"","
- .S DIC(0)="L",DIC("DR")="1////"_ACRACPT_";2////O"
- .D FILE^ACRFDIC
- S ACRDA(3)=+Y
- S:'$D(^AFSHRCDS(ACRDA,"D",ACRDA(2),"I",ACRDA(3),"S",0)) ^AFSHRCDS(ACRDA,"D",ACRDA(2),"I",ACRDA(3),"S",0)="^9002322.216"
- K X
- L +^AFSHRCDS(ACRDA,"D",ACRDA(2),"I",ACRDA(3),"S",0):4 Q:'$T
- S X=$P(^AFSHRCDS(ACRDA,"D",ACRDA(2),"I",ACRDA(3),"S",0),U,3)
- S X=X+1
- L -^AFSHRCDS(ACRDA,"D",ACRDA(2),"I",ACRDA(3),"S",0):0
- Q:'$D(X)
- S DA(3)=ACRDA
- S DA(2)=ACRDA(2)
- S DA(1)=ACRDA(3)
- ;S X=X ;COMMENT OUT ;ACR*2.1*3.09
- S DIC="^AFSHRCDS("_ACRDA_",""D"","_ACRDA(2)_",""I"","_ACRDA(3)_",""S"","
- S DIC(0)="L"
- D FILE^ACRFDIC
- S ACRCNT=$G(ACRCNT)+1
- S DA(3)=ACRDA
- S DA(2)=ACRDA(2)
- S DA(1)=ACRDA(3)
- S DA=+Y
- S DIE="^AFSHRCDS("_ACRDA_",""D"","_ACRDA(2)_",""I"","_ACRDA(3)_",""S"","
- ;I $G(ACRIV)="PAY",'$G(ACRRECOV) Q:$G(ACRDHR)="" D DR ;ACR*2.1*16.06 IM15505
- I $G(ACRIV)["PAY",'$G(ACRRECOV) Q:$G(ACRDHR)="" D DR ;ACR*2.1*16.06 IM15505
- S DR=ACRDR
- I '$G(ACRFMS) D
- . Q:'$G(ACRD0) Q:'$G(ACRD1) Q:'$G(ACRD2) ;ACR*2.1*3.08
- . S ACRFMS=$P($G(^AFSLAFP(ACRD0,1,ACRD1,1,ACRD2,"ARMS")),U,4) ;ACR*2.1*3.08
- I $E(DR,$L(DR))=";" S DR=$P(DR,";",1,$L(DR,";")-1)
- S DR=DR_";99////"_$G(ACRFMS)
- D DIE^ACRFDIC
- K ACRFMS
- Q
- DR ;CREATE DR STRING FROM 1166 DATA RECORD
- N Z
- S Z=ACRDHR
- S DR="1////"_$E(Z)
- S DR=DR_";2///"_$E(Z,2,7)
- S DR=DR_";3////"_$E(Z,8,10)
- S DR=DR_";4////"_$E(Z,11)
- S DR=DR_";5////"_$E(Z,12)
- S DR=DR_";6////"_$E(Z,13,15)
- S DR=DR_";7////"_$E(Z,16,25)
- S DR=DR_";8////"_$E(Z,26,28)
- S DR=DR_";9////"_$E(Z,29,38)
- S DR=DR_";10////"_$E(Z,39)
- S DR=DR_";11////"_$E(Z,40)
- S DR=DR_";12////"_$E(Z,41,47)
- S DR=DR_";13////"_$E(Z,48,51)
- S DR=DR_";14////"_$E(Z,52,63)
- S DR=DR_";15////"_$E(Z,64)
- S DR=DR_";16////"_$E(Z,65,79)
- S DR=DR_";17////"_$E(Z,80,94)
- S DR=DR_";18////"_$E(Z,95,104)
- S DR=DR_";26////"_$E(Z,126,129)
- S DR=DR_";27////"_$E(Z,130,133)
- S DR=DR_";28////"_$E(Z,134,135)
- S DR=DR_";29////"_$E(Z,136)
- S DR=DR_";30////"_$E(Z,137,140)
- S ACRDR=DR
- Q
- HOLD(ACRFY,ACR3,ACRFYDA,ACRBATDA,ACRSEQDA) ;
- ;----- HOLD DHRS FOR NEW FISCAL YEAR
- ;
- ; BASED ON ENTRY IN FIELD 401 HOLD DHRS FOR NEW FY
- ; IN THE FMS SYSTEM DEFAULTS FILE
- ;
- N ACRDOCDA
- I '$P($G(^ACRSYS(1,401)),U) Q 0
- I ACRFY,ACRFY=$P($G(^ACRSYS(1,401)),U) Q 1
- I ACR3="050",ACRFY=$P($G(^ACRSYS(1,401)),U) Q 1
- I "^181^182^191^192^061^242^"[(U_ACR3_U) D
- . I $G(ACRFYDA),$G(ACRBATDA),$G(ACRSEQDA) D ;ACR*2.1*3.15
- . . S ACRDOCDA=$P($G(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,"ARMS")),U) ;ACR*2.1*3.15
- I $G(ACRDOCDA),$$DOCFY(ACRDOCDA)=$P($G(^ACRSYS(1,401)),U) Q 1
- Q 0
- DOCFY(ACRDOCDA) ;
- ;----- RETURNS FY OF FUNDS FOR ARMS DOCUMENT
- ;
- S Y=""
- S Y=$P($G(^ACRDOC(ACRDOCDA,0)),U,6)
- I Y S Y=$P($G(^ACRLOCB(Y,"DT")),U)
- Q Y
- ACRFDHR1 ;IHS/OIRM/DSD/THL,AEF - PROCESS DOCUMENT HISTORY RECORDS - CON'T; [ 02/02/2005 10:25 AM ]
- +1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**3,16**;NOV 05, 2001
- +2 ;;
- DHRRCD ;EP;TO CREATE DHR RECORD IN DHR PROGRAM
- +1 ; Quit if hold for next fiscal year
- +2 ;ACR*2.1*3.08
- IF $$HOLD($GET(ACRFY),$GET(ACR3),$GET(ACRD0),$GET(ACRD1),$GET(ACRD2))
- QUIT
- +3 ;
- +4 ; Quit if not 'activate DHR interface'
- +5 IF $PIECE(^ACRSYS($$SYS^ACRFUTL($PIECE($GET(ACRDOC0),U,8)),"DT"),U,25)'=1
- QUIT
- +6 ;
- +7 ; Quit if no DHR records
- +8 IF '$DATA(^AFSHRCDS(0))#2
- QUIT
- +9 ;
- +10 ; Quit if Travel DHR only, and reference code is not 130 or 600 (travel order or voucher)
- +11 IF $PIECE(^ACRSYS($$SYS^ACRFUTL($PIECE($GET(ACRDOC0),U,8)),"DT"),U,32)
- IF "^130^600^"'[(U_ACRREF_U)
- QUIT
- +12 ;
- +13 ; Quit if multi-use standard re and not 'create DHR for Fedstrip'
- +14 IF ACRREF=210
- IF '$PIECE(^ACRSYS($$SYS^ACRFUTL($PIECE($GET(ACRDOC0),U,8)),"DT"),U,38)
- QUIT
- +15 ;
- +16 ;I $P(^ACRSYS(1,"DT"),U,37),"^600^618^"[(U_ACRREF_U),"^181^182^191^192^281^"[(U_(ACR3)_U) Q
- +17 NEW ACRDATE,ACRDA
- +18 SET ACRDATE=DT
- +19 SET ACRDA=$SELECT($GET(ACRIV)'="PAY":5,1:6)
- DATE IF $PIECE($GET(^AFSHRCDS(ACRDA,"D",ACRDATE,"I",1,0)),U,3)="C"
- Begin DoDot:1
- +1 SET X1=ACRDATE
- +2 SET X2=1
- +3 DO C^%DTC
- +4 SET ACRDATE=X
- End DoDot:1
- GOTO DATE
- +5 IF '$DATA(^AFSHRCDS(ACRDA,0))#2
- Begin DoDot:1
- +6 SET (X,DINUM)=ACRDA
- +7 SET DIC="^AFSHRCDS("
- +8 SET DIC(0)="L"
- +9 DO FILE^ACRFDIC
- End DoDot:1
- +10 IF $DATA(ACRDHRZ)
- SET ACRDATE=ACRDHRZ
- +11 IF '$DATA(^AFSHRCDS(ACRDA,"D",0))
- SET ^AFSHRCDS(ACRDA,"D",0)="^9002322.02D"
- +12 IF $GET(ACRIV)'="PAY"
- IF ACRREF'="043"
- Begin DoDot:1
- +13 SET ACRACPT=$PIECE(ACRDOC0,U,8)
- +14 SET ACRACPT=$PIECE(^ACRPO(ACRACPT,0),U,4)
- +15 IF ACRACPT
- IF $DATA(^AUTTACPT(ACRACPT,0))
- SET ACRACPT=$PIECE(^AUTTACPT(ACRACPT,0),U)
- End DoDot:1
- IF 1
- +16 IF $DATA(^AFSHRCDS(ACRDA,"D",ACRDATE,0))#2
- SET Y=ACRDATE
- +17 IF '$TEST
- Begin DoDot:1
- +18 SET DA(1)=ACRDA
- +19 SET (X,DINUM)=ACRDATE
- +20 SET DIC="^AFSHRCDS("_ACRDA_",""D"","
- +21 SET DIC(0)="L"
- +22 DO FILE^ACRFDIC
- End DoDot:1
- +23 SET ACRDA(2)=+Y
- +24 IF '$DATA(^AFSHRCDS(ACRDA,"D",ACRDA(2),"I",0))#2
- SET ^AFSHRCDS(ACRDA,"D",ACRDA(2),"I",0)="^9002322.21"
- +25 IF $DATA(^AFSHRCDS(ACRDA,"D",ACRDA(2),"I","B","R"))
- SET Y=$ORDER(^("R",0))
- +26 IF '$TEST
- Begin DoDot:1
- +27 SET DA(2)=ACRDA
- +28 SET DA(1)=ACRDA(2)
- +29 SET X="R"
- +30 SET DIC="^AFSHRCDS("_ACRDA_",""D"","_ACRDA(2)_",""I"","
- +31 SET DIC(0)="L"
- SET DIC("DR")="1////"_ACRACPT_";2////O"
- +32 DO FILE^ACRFDIC
- End DoDot:1
- +33 SET ACRDA(3)=+Y
- +34 IF '$DATA(^AFSHRCDS(ACRDA,"D",ACRDA(2),"I",ACRDA(3),"S",0))
- SET ^AFSHRCDS(ACRDA,"D",ACRDA(2),"I",ACRDA(3),"S",0)="^9002322.216"
- +35 KILL X
- +36 LOCK +^AFSHRCDS(ACRDA,"D",ACRDA(2),"I",ACRDA(3),"S",0):4
- IF '$TEST
- QUIT
- +37 SET X=$PIECE(^AFSHRCDS(ACRDA,"D",ACRDA(2),"I",ACRDA(3),"S",0),U,3)
- +38 SET X=X+1
- +39 LOCK -^AFSHRCDS(ACRDA,"D",ACRDA(2),"I",ACRDA(3),"S",0):0
- +40 IF '$DATA(X)
- QUIT
- +41 SET DA(3)=ACRDA
- +42 SET DA(2)=ACRDA(2)
- +43 SET DA(1)=ACRDA(3)
- +44 ;S X=X ;COMMENT OUT ;ACR*2.1*3.09
- +45 SET DIC="^AFSHRCDS("_ACRDA_",""D"","_ACRDA(2)_",""I"","_ACRDA(3)_",""S"","
- +46 SET DIC(0)="L"
- +47 DO FILE^ACRFDIC
- +48 SET ACRCNT=$GET(ACRCNT)+1
- +49 SET DA(3)=ACRDA
- +50 SET DA(2)=ACRDA(2)
- +51 SET DA(1)=ACRDA(3)
- +52 SET DA=+Y
- +53 SET DIE="^AFSHRCDS("_ACRDA_",""D"","_ACRDA(2)_",""I"","_ACRDA(3)_",""S"","
- +54 ;I $G(ACRIV)="PAY",'$G(ACRRECOV) Q:$G(ACRDHR)="" D DR ;ACR*2.1*16.06 IM15505
- +55 ;ACR*2.1*16.06 IM15505
- IF $GET(ACRIV)["PAY"
- IF '$GET(ACRRECOV)
- IF $GET(ACRDHR)=""
- QUIT
- DO DR
- +56 SET DR=ACRDR
- +57 IF '$GET(ACRFMS)
- Begin DoDot:1
- +58 ;ACR*2.1*3.08
- IF '$GET(ACRD0)
- QUIT
- IF '$GET(ACRD1)
- QUIT
- IF '$GET(ACRD2)
- QUIT
- +59 ;ACR*2.1*3.08
- SET ACRFMS=$PIECE($GET(^AFSLAFP(ACRD0,1,ACRD1,1,ACRD2,"ARMS")),U,4)
- End DoDot:1
- +60 IF $EXTRACT(DR,$LENGTH(DR))=";"
- SET DR=$PIECE(DR,";",1,$LENGTH(DR,";")-1)
- +61 SET DR=DR_";99////"_$GET(ACRFMS)
- +62 DO DIE^ACRFDIC
- +63 KILL ACRFMS
- +64 QUIT
- DR ;CREATE DR STRING FROM 1166 DATA RECORD
- +1 NEW Z
- +2 SET Z=ACRDHR
- +3 SET DR="1////"_$EXTRACT(Z)
- +4 SET DR=DR_";2///"_$EXTRACT(Z,2,7)
- +5 SET DR=DR_";3////"_$EXTRACT(Z,8,10)
- +6 SET DR=DR_";4////"_$EXTRACT(Z,11)
- +7 SET DR=DR_";5////"_$EXTRACT(Z,12)
- +8 SET DR=DR_";6////"_$EXTRACT(Z,13,15)
- +9 SET DR=DR_";7////"_$EXTRACT(Z,16,25)
- +10 SET DR=DR_";8////"_$EXTRACT(Z,26,28)
- +11 SET DR=DR_";9////"_$EXTRACT(Z,29,38)
- +12 SET DR=DR_";10////"_$EXTRACT(Z,39)
- +13 SET DR=DR_";11////"_$EXTRACT(Z,40)
- +14 SET DR=DR_";12////"_$EXTRACT(Z,41,47)
- +15 SET DR=DR_";13////"_$EXTRACT(Z,48,51)
- +16 SET DR=DR_";14////"_$EXTRACT(Z,52,63)
- +17 SET DR=DR_";15////"_$EXTRACT(Z,64)
- +18 SET DR=DR_";16////"_$EXTRACT(Z,65,79)
- +19 SET DR=DR_";17////"_$EXTRACT(Z,80,94)
- +20 SET DR=DR_";18////"_$EXTRACT(Z,95,104)
- +21 SET DR=DR_";26////"_$EXTRACT(Z,126,129)
- +22 SET DR=DR_";27////"_$EXTRACT(Z,130,133)
- +23 SET DR=DR_";28////"_$EXTRACT(Z,134,135)
- +24 SET DR=DR_";29////"_$EXTRACT(Z,136)
- +25 SET DR=DR_";30////"_$EXTRACT(Z,137,140)
- +26 SET ACRDR=DR
- +27 QUIT
- HOLD(ACRFY,ACR3,ACRFYDA,ACRBATDA,ACRSEQDA) ;
- +1 ;----- HOLD DHRS FOR NEW FISCAL YEAR
- +2 ;
- +3 ; BASED ON ENTRY IN FIELD 401 HOLD DHRS FOR NEW FY
- +4 ; IN THE FMS SYSTEM DEFAULTS FILE
- +5 ;
- +6 NEW ACRDOCDA
- +7 IF '$PIECE($GET(^ACRSYS(1,401)),U)
- QUIT 0
- +8 IF ACRFY
- IF ACRFY=$PIECE($GET(^ACRSYS(1,401)),U)
- QUIT 1
- +9 IF ACR3="050"
- IF ACRFY=$PIECE($GET(^ACRSYS(1,401)),U)
- QUIT 1
- +10 IF "^181^182^191^192^061^242^"[(U_ACR3_U)
- Begin DoDot:1
- +11 ;ACR*2.1*3.15
- IF $GET(ACRFYDA)
- IF $GET(ACRBATDA)
- IF $GET(ACRSEQDA)
- Begin DoDot:2
- +12 ;ACR*2.1*3.15
- SET ACRDOCDA=$PIECE($GET(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,"ARMS")),U)
- End DoDot:2
- End DoDot:1
- +13 IF $GET(ACRDOCDA)
- IF $$DOCFY(ACRDOCDA)=$PIECE($GET(^ACRSYS(1,401)),U)
- QUIT 1
- +14 QUIT 0
- DOCFY(ACRDOCDA) ;
- +1 ;----- RETURNS FY OF FUNDS FOR ARMS DOCUMENT
- +2 ;
- +3 SET Y=""
- +4 SET Y=$PIECE($GET(^ACRDOC(ACRDOCDA,0)),U,6)
- +5 IF Y
- SET Y=$PIECE($GET(^ACRLOCB(Y,"DT")),U)
- +6 QUIT Y