ACRFUFMX ;IHS/OIRM/DSD/AEF - UTILITY STANDALONE TO READ OPEN DOCUMENTS FROM CORE FOR UFMS [ 05/09/2007 9:44 AM ]
;;2.1;ADMIN RESOURCE MGMT SYSTEM;**22**;NOV 05, 2001
;NEW ROUTINE; CONTINUATION OF ACRFUFMZ ;ACR*2.1*22 UFMS
;
; *********************************************
;
; This routine is a continuation of ACRFUFMZ. If there is no match to the
; FMS DOCUMENT file, it attempts to match the CORE document number in the
; 1166 APPROVALS FOR PAYMENT and the FMS DOCUMENT HISTORY RECORD files.
;
Q ;MUST ENTER AT LINE LABELS
;
; ****************************************************
HIT1166(ACRCDOC,FLAG) ;EP; CHECK 1166 APPROVALS FOR PAYMENT FILE
;
; - Enters with: ACRCDOC = CORE document number
; FLAG = 0 OR 1
; ACRCORE string VARIABLES from CORE file
;
; ACRCTYP ;CORE DOCUMENT TYPE
; ACRCAP ;CORE ACCOUNTING POINT
; ACRCFY ;CORE FISCAL YEAR
; ACRCCAN ;CORE CAN
; ACRCOCC ;CORE OBJECT CLASS CODE
; ACRCEIN ;CORE VENDOR EIN
K ACRXX
D LOOP11(ACRCDOC,.ACRXX) ;LOOP THROUGH 1166 APPROVALS FOR PAYMENT FILE
S:'$G(ACRXX) ACRXX=0
Q:FLAG ;IF FROM FMS DOC,ONLY WANT 1166 FILE POINTERS
S ACRHIT=0
F I=1:1:ACRXX D ;ALLOW FOR MULTIPLES
.S ACRMATCH=$$MATCH2^ACRFUFMU(.ACRXX,I,.ACRV)
.I ACRMATCH'=0 D
..D ITEMS11^ACRFUFMI(ACRMATCH) ;SETS ITEMS INTO ^ACRZ("ITEMS"
..S ACRHIT=1
I 'ACRHIT D SETCK^ACRFUFMU("NO MATCH 1166",ACR)
I ACRHIT D SET^ACRFUFMZ
Q
;
HITDHR(ACRCDOC) ;EP; CHECK FMS DOCUMENT HISTORY RECORD FILE
;
; - Enters with: ACRCDOC = CORE document number
;
; ****************************************************
N ACRZ,ACRD1,ACRI,ACRTCOD,ACRAMT
K ACRXX
S (ACRZ,ACRMATCH,ACRX)=0
F S ACRZ=$O(^ACRDHR("B",ACRCDOC,ACRZ)) Q:ACRZ="" D
.S ACRD1=$G(^ACRDHR(ACRZ,1))
.S ACREDAT=$$SLDATE^ACRFUTL($P(ACRD1,U,2)) ;EFFECTIVE DATE
.S ACRCAN=$P(ACRD1,U,12) ;CAN
.S ACROCC=$P(ACRD1,U,13) ;OBJECT CLASS CODE
.S ACRAMT=$P(ACRD1,U,14) ;DOLLAR AMOUNT
.S ACRTCOD=$P(ACRD1,U,3) ;TRANSACTION CODE
.S ACRI=$E(ACRTCOD,1,2) ;TRANSACTION CODE
.S ACRIFIN=$S(ACRI="05":"OBLIGATION",ACRI="18":"PARTIAL INVOICE",ACRI="19":"FINAL INVOICE",1:ACRI)
.S ACRVEIN=$TR($P(ACRD1,U,16)," ") ;VENDOR EIN+
.S:$G(ACRV)'>0 ACRV=$$VEN^ACRFUFMU(ACRVEIN)
.S ACRCCIEN=$$CCVEN^ACRFUFMU ;CC DEFAULT VENDOR IEN
.S ACRCIEN=$$VEN^ACRFUFMU(ACRCEIN)
.I ACRCIEN,ACRCIEN=ACRCCIEN S ACRV=ACRCCIEN ;CHANGE TO CC DEFAULT VENDOR
.S ACRFY=$P(ACRD1,U,28) ;2-DIGIT FY
.S ACRMATCH=$$MATCH^ACRFUFMU
.S ACRSTR=ACRCDOC_U_ACREDAT_U ;NO REQ OR INVOICE INFO
.S ACRX=$G(ACRX)+1 ;COUNTER
.S ACRXX(ACRMATCH,ACRX,ACRV)=ACRSTR_"@"_ACRZ_U_ACRCAN_U_ACROCC_U_ACRAMT_U_ACRIFIN_U_ACRTCOD ;ALLOW FOR MULTIPLES
.S ACRXX=ACRX
S ACRHIT=0
F I=1:1:ACRXX D
.S ACRMATCH=$$MATCH2^ACRFUFMU(.ACRXX,I,ACRV)
.I ACRMATCH'=0 D
..D ITEMSDHR^ACRFUFMI(ACRMATCH,ACRCORE) ;SETS ITEMS INTO ^ACRZ("ITEMS"
..S ACRHIT=1
I 'ACRHIT D SETCK^ACRFUFMU("NO MATCH DHR",ACR)
I ACRHIT D SET^ACRFUFMZ
Q
; ************************************************
LOOP11(ACRCDOC,ACRXX) ;
N ACRAFY,ACRABCH,ACRASEQ,ACRADATE
S (ACRAFY,ACRMATCH,ACRX)=0
F S ACRAFY=$O(^AFSLAFP("N",ACRCDOC,ACRAFY)) Q:'ACRAFY D
.S ACRABCH=0
.F S ACRABCH=$O(^AFSLAFP("N",ACRCDOC,ACRAFY,ACRABCH)) Q:'ACRABCH D
..S ACRASEQ=0
..F S ACRASEQ=$O(^AFSLAFP("N",ACRCDOC,ACRAFY,ACRABCH,ACRASEQ)) Q:'ACRASEQ D
...S ACRAF0=$G(^AFSLAFP(ACRAFY,1,ACRABCH,1,ACRASEQ,0))
...Q:ACRAF0']""
...S ACRAF3=$G(^AFSLAFP(ACRAFY,1,ACRABCH,1,ACRASEQ,3))
...S ACRFY=$P(ACRAF3,U,3)
...S:ACRFY="" ACRFY=$P(^AFSLAFP(ACRAFY,0),U) ;FY OF BATCH
...S ACRAF34=$P(ACRAF3,U,4) ;INVOICE IN LIEU OF IDENTIFIER
...S ACRADAT=$P(ACRAF0,U,13) ;DATE
...I ACRADAT="" S ACRADAT=$P($G(^AFSLAFP(ACRAFY,1,ACRABCH,1,ACRASEQ,2)),U)
...S ACRADAT=$$SLDATE^ACRFUTL(ACRADAT)
...I ACRADAT="" S ACRADAT="0/0/"_ACRFY ;WHEN ALL ELSE FAILS
...S ACRCANDA=$P(ACRAF0,U,7)
...S ACROCCDA=$P(ACRAF0,U,8)
...D PIECE^ACRFUFMU
...S ACRMATCH=$$MATCH^ACRFUFMU
...S:$G(ACRV)'>0 ACRV=+$P(ACRAF0,U,10) ;DON'T RESET VENDOR
...I ACRREQ,'ACRMATCH D S ACRX=0 Q ;IN CASE PAYMENT DOESN'T MATCH
....S ACRSTR=ACRREQ_U_ACRADAT_U_ACRAF34
...S ACRSTR=ACRCDOC_U_ACRADAT_U_ACRAF34 ;NO REQ GIVE INVOICE
...S ACRX=$G(ACRX)+1 ;COUNTER
...S ACRXX(ACRMATCH,ACRX,ACRV)=ACRSTR_"@"_ACRAFY_U_ACRABCH_U_ACRASEQ
...S ACRXX=ACRX ;COUNT MATCHES
Q
ACRFUFMX ;IHS/OIRM/DSD/AEF - UTILITY STANDALONE TO READ OPEN DOCUMENTS FROM CORE FOR UFMS [ 05/09/2007 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGMT SYSTEM;**22**;NOV 05, 2001
+2 ;NEW ROUTINE; CONTINUATION OF ACRFUFMZ ;ACR*2.1*22 UFMS
+3 ;
+4 ; *********************************************
+5 ;
+6 ; This routine is a continuation of ACRFUFMZ. If there is no match to the
+7 ; FMS DOCUMENT file, it attempts to match the CORE document number in the
+8 ; 1166 APPROVALS FOR PAYMENT and the FMS DOCUMENT HISTORY RECORD files.
+9 ;
+10 ;MUST ENTER AT LINE LABELS
QUIT
+11 ;
+12 ; ****************************************************
HIT1166(ACRCDOC,FLAG) ;EP; CHECK 1166 APPROVALS FOR PAYMENT FILE
+1 ;
+2 ; - Enters with: ACRCDOC = CORE document number
+3 ; FLAG = 0 OR 1
+4 ; ACRCORE string VARIABLES from CORE file
+5 ;
+6 ; ACRCTYP ;CORE DOCUMENT TYPE
+7 ; ACRCAP ;CORE ACCOUNTING POINT
+8 ; ACRCFY ;CORE FISCAL YEAR
+9 ; ACRCCAN ;CORE CAN
+10 ; ACRCOCC ;CORE OBJECT CLASS CODE
+11 ; ACRCEIN ;CORE VENDOR EIN
+12 KILL ACRXX
+13 ;LOOP THROUGH 1166 APPROVALS FOR PAYMENT FILE
DO LOOP11(ACRCDOC,.ACRXX)
+14 IF '$GET(ACRXX)
SET ACRXX=0
+15 ;IF FROM FMS DOC,ONLY WANT 1166 FILE POINTERS
IF FLAG
QUIT
+16 SET ACRHIT=0
+17 ;ALLOW FOR MULTIPLES
FOR I=1:1:ACRXX
Begin DoDot:1
+18 SET ACRMATCH=$$MATCH2^ACRFUFMU(.ACRXX,I,.ACRV)
+19 IF ACRMATCH'=0
Begin DoDot:2
+20 ;SETS ITEMS INTO ^ACRZ("ITEMS"
DO ITEMS11^ACRFUFMI(ACRMATCH)
+21 SET ACRHIT=1
End DoDot:2
End DoDot:1
+22 IF 'ACRHIT
DO SETCK^ACRFUFMU("NO MATCH 1166",ACR)
+23 IF ACRHIT
DO SET^ACRFUFMZ
+24 QUIT
+25 ;
HITDHR(ACRCDOC) ;EP; CHECK FMS DOCUMENT HISTORY RECORD FILE
+1 ;
+2 ; - Enters with: ACRCDOC = CORE document number
+3 ;
+4 ; ****************************************************
+5 NEW ACRZ,ACRD1,ACRI,ACRTCOD,ACRAMT
+6 KILL ACRXX
+7 SET (ACRZ,ACRMATCH,ACRX)=0
+8 FOR
SET ACRZ=$ORDER(^ACRDHR("B",ACRCDOC,ACRZ))
IF ACRZ=""
QUIT
Begin DoDot:1
+9 SET ACRD1=$GET(^ACRDHR(ACRZ,1))
+10 ;EFFECTIVE DATE
SET ACREDAT=$$SLDATE^ACRFUTL($PIECE(ACRD1,U,2))
+11 ;CAN
SET ACRCAN=$PIECE(ACRD1,U,12)
+12 ;OBJECT CLASS CODE
SET ACROCC=$PIECE(ACRD1,U,13)
+13 ;DOLLAR AMOUNT
SET ACRAMT=$PIECE(ACRD1,U,14)
+14 ;TRANSACTION CODE
SET ACRTCOD=$PIECE(ACRD1,U,3)
+15 ;TRANSACTION CODE
SET ACRI=$EXTRACT(ACRTCOD,1,2)
+16 SET ACRIFIN=$SELECT(ACRI="05":"OBLIGATION",ACRI="18":"PARTIAL INVOICE",ACRI="19":"FINAL INVOICE",1:ACRI)
+17 ;VENDOR EIN+
SET ACRVEIN=$TRANSLATE($PIECE(ACRD1,U,16)," ")
+18 IF $GET(ACRV)'>0
SET ACRV=$$VEN^ACRFUFMU(ACRVEIN)
+19 ;CC DEFAULT VENDOR IEN
SET ACRCCIEN=$$CCVEN^ACRFUFMU
+20 SET ACRCIEN=$$VEN^ACRFUFMU(ACRCEIN)
+21 ;CHANGE TO CC DEFAULT VENDOR
IF ACRCIEN
IF ACRCIEN=ACRCCIEN
SET ACRV=ACRCCIEN
+22 ;2-DIGIT FY
SET ACRFY=$PIECE(ACRD1,U,28)
+23 SET ACRMATCH=$$MATCH^ACRFUFMU
+24 ;NO REQ OR INVOICE INFO
SET ACRSTR=ACRCDOC_U_ACREDAT_U
+25 ;COUNTER
SET ACRX=$GET(ACRX)+1
+26 ;ALLOW FOR MULTIPLES
SET ACRXX(ACRMATCH,ACRX,ACRV)=ACRSTR_"@"_ACRZ_U_ACRCAN_U_ACROCC_U_ACRAMT_U_ACRIFIN_U_ACRTCOD
+27 SET ACRXX=ACRX
End DoDot:1
+28 SET ACRHIT=0
+29 FOR I=1:1:ACRXX
Begin DoDot:1
+30 SET ACRMATCH=$$MATCH2^ACRFUFMU(.ACRXX,I,ACRV)
+31 IF ACRMATCH'=0
Begin DoDot:2
+32 ;SETS ITEMS INTO ^ACRZ("ITEMS"
DO ITEMSDHR^ACRFUFMI(ACRMATCH,ACRCORE)
+33 SET ACRHIT=1
End DoDot:2
End DoDot:1
+34 IF 'ACRHIT
DO SETCK^ACRFUFMU("NO MATCH DHR",ACR)
+35 IF ACRHIT
DO SET^ACRFUFMZ
+36 QUIT
+37 ; ************************************************
LOOP11(ACRCDOC,ACRXX) ;
+1 NEW ACRAFY,ACRABCH,ACRASEQ,ACRADATE
+2 SET (ACRAFY,ACRMATCH,ACRX)=0
+3 FOR
SET ACRAFY=$ORDER(^AFSLAFP("N",ACRCDOC,ACRAFY))
IF 'ACRAFY
QUIT
Begin DoDot:1
+4 SET ACRABCH=0
+5 FOR
SET ACRABCH=$ORDER(^AFSLAFP("N",ACRCDOC,ACRAFY,ACRABCH))
IF 'ACRABCH
QUIT
Begin DoDot:2
+6 SET ACRASEQ=0
+7 FOR
SET ACRASEQ=$ORDER(^AFSLAFP("N",ACRCDOC,ACRAFY,ACRABCH,ACRASEQ))
IF 'ACRASEQ
QUIT
Begin DoDot:3
+8 SET ACRAF0=$GET(^AFSLAFP(ACRAFY,1,ACRABCH,1,ACRASEQ,0))
+9 IF ACRAF0']""
QUIT
+10 SET ACRAF3=$GET(^AFSLAFP(ACRAFY,1,ACRABCH,1,ACRASEQ,3))
+11 SET ACRFY=$PIECE(ACRAF3,U,3)
+12 ;FY OF BATCH
IF ACRFY=""
SET ACRFY=$PIECE(^AFSLAFP(ACRAFY,0),U)
+13 ;INVOICE IN LIEU OF IDENTIFIER
SET ACRAF34=$PIECE(ACRAF3,U,4)
+14 ;DATE
SET ACRADAT=$PIECE(ACRAF0,U,13)
+15 IF ACRADAT=""
SET ACRADAT=$PIECE($GET(^AFSLAFP(ACRAFY,1,ACRABCH,1,ACRASEQ,2)),U)
+16 SET ACRADAT=$$SLDATE^ACRFUTL(ACRADAT)
+17 ;WHEN ALL ELSE FAILS
IF ACRADAT=""
SET ACRADAT="0/0/"_ACRFY
+18 SET ACRCANDA=$PIECE(ACRAF0,U,7)
+19 SET ACROCCDA=$PIECE(ACRAF0,U,8)
+20 DO PIECE^ACRFUFMU
+21 SET ACRMATCH=$$MATCH^ACRFUFMU
+22 ;DON'T RESET VENDOR
IF $GET(ACRV)'>0
SET ACRV=+$PIECE(ACRAF0,U,10)
+23 ;IN CASE PAYMENT DOESN'T MATCH
IF ACRREQ
IF 'ACRMATCH
Begin DoDot:4
+24 SET ACRSTR=ACRREQ_U_ACRADAT_U_ACRAF34
End DoDot:4
SET ACRX=0
QUIT
+25 ;NO REQ GIVE INVOICE
SET ACRSTR=ACRCDOC_U_ACRADAT_U_ACRAF34
+26 ;COUNTER
SET ACRX=$GET(ACRX)+1
+27 SET ACRXX(ACRMATCH,ACRX,ACRV)=ACRSTR_"@"_ACRAFY_U_ACRABCH_U_ACRASEQ
+28 ;COUNT MATCHES
SET ACRXX=ACRX
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT
