- 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
