Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACRFUFMI

ACRFUFMI.m

Go to the documentation of this file. 
  1. ACRFUFMI ;IHS/OIRM/DSD/AEF - PO ITEMS ORDERED DATA EXTRACT [ 05/11/2007  10:05 AM ]
  1.  ;;2.1;ADMIN RESOURCE MGT SYSTEM;**22**;NOV 05, 2001
  1.  ;NEW ROUTINE FOR UFMS ARMS CORE OPEN DOCUMENT MATCH AND ITEM RETREIVAL;ACR*2.1*22
  1.  ;
  1. DESC ;----- ROUTINE DESCRIPTION    
  1.  ;;Create Items Ordered Flat File
  1.  ;;
  1.  ;;This option will gather LINE item data for ARMS/CORE Open Documents
  1.  ;;match and place them into a UNIX file which can be imported
  1.  ;;into a database
  1.  ;;
  1.  ;;Fields included in the extract file are:f
  1.  ;;     1
  1.  ;;     3 Item Number                   
  1.  ;;     4
  1.  ;;    19 Keyword
  1.  ;;    10 Quantity Required             23 
  1.  ;;    11 Unit of Issue                 24  
  1.  ;;    12 Unit Cost                     25  
  1.  ;;    13                 26 Item Description
  1.  Q  ; MUST ENTER AT LINE LABEL
  1.  ;
  1. ITEMS(ACRDOC,ACRSSDA,ACRCORE,ACRRFIN,ACRIFIN,ACRHIT)      ; EP
  1.  ;----- GET ITEM DATA AND PUT IN ^ACRZ("ITEMS" GLOBAL
  1.  ;
  1.  N X,Z,ACRUI,ACRITM,ACRUCST,ACRKW,ACRDEPT,ACRQTY,ACRCANDA,ACRSINO
  1.  N ACRDLCOD,ACRDESC,ACRMAIL,ACRSHIP,CLOCNAM,CLCODN,ACRECST
  1.  S ACRHIT=0
  1.  D SS(ACRSSDA,.ACRCANDA)
  1.  D HIT1166^ACRFUFMX(ACRDOC,1)              ;RETURNS ACRXX
  1.  I ACRXX=0 D  Q                            ;NOTHING IN PAYMENTS
  1.  .D RR(ACRSSDA)
  1.  .D CAN(ACRCANDA)
  1.  .D SET(ACRSSDA)
  1.  .S ACRHIT=1
  1.  F I=1:1:ACRXX D
  1.  .S ARRAY=$$MATCH2^ACRFUFMU(.ACRXX,I,.ACRV)
  1.  .I ARRAY'=0 D
  1.  ..D 112
  1.  ..D RR(ACRSSDA)
  1.  ..D CAN(ACRCANDA)
  1.  ..D SET(ACRSSDA)
  1.  ..S ACRHIT=1
  1.  Q
  1. SSX(X,N,B,E) ;RETURN PIECE FROM FMS SUPPLIES AND SERVICES FILE
  1.  ;
  1.  ; ENTER:  X = IEN OF FMS SUPPLIES AND SERVICES FILE
  1.  ;         N = NODE NUMBER OR NAME
  1.  ;         B = BEGIN PIECE NUMBER
  1.  ;         E = END PIECE NUMBER
  1.  ; RETURN: Y = DATA PIECE
  1.  ;  
  1.  N Y
  1.  S Y=""
  1.  I X S Y=$P($G(^ACRSS(X,N)),U,B,E)
  1.  Q Y
  1. LOCB(X) ;EP -- RETURNS DEPARTMENT/PROGRAM POINTER ***
  1.  ;
  1.  ;      X  =  FMS DEPARTMENT ACCOUNT IEN
  1.  ;
  1.  N Y
  1.  S Y=""
  1.  I X S Y=$P($G(^ACRLOCB(X,0)),U,5)         ;FMS DEPARTMENT ACCOUNT
  1.  Q Y
  1. PRG(X) ;EP -- RETURNS DEPARTMENT NAME ***
  1.  ;
  1.  ;      X  =  FMS DEPARTMENT/PROGRAM IEN
  1.  ;
  1.  N Y
  1.  S Y=""
  1.  I X S Y=$P($G(^AUTTPRG(X,0)),U)           ;FMS DEPARTMENT/PROGRAM
  1.  Q Y
  1.  ;
  1. SS(X,ACRCANDA) ;SET VARIABLES FROM THE FMS SUPPLIES AND SERVICES FILE
  1.  ;
  1.  N DPTR,PRGPTR
  1.  S ACRITM=$$SSX(X,0,1,1)                   ; ITEM NUMBER IN DOC
  1.  S ACRCANDA=$$SSX(X,0,5,5)                  ; COMMON ACCOUNTING NUMBER POINTER
  1.  S DPTR=$$SSX(X,0,6,6)                     ; DEPARTMENT ACCOUNT POINTER
  1.  S ACRSINO=$$SSX(X,0,12,12)                ; ARMS STANDARD ITEM
  1.  S ACRQTY=$$SSX(X,"DT",1,1)                ; QUANTITY REQUESTED
  1.  S ACRKW=$$SSX(X,"NMS",5,5)                ; KEYWORD
  1.  S ACRUCST=$$SSX(X,"DT",3,3)               ; UNIT COST
  1.  S ACRUI=$$UI(X)                           ; UNIT OF ISSUE
  1.  S ACRECST=$$SSX(X,"DT",4,4)               ; ESTIMATED COST
  1.  I ACRQTY="",ACRUCST="",ACRUI="" D
  1.  .I ACRECST>0 S ACRQTY=1,ACRUI="USD",ACRUCST=ACRECST
  1.  S ACRQRCD=$$SSX(X,"DT",5,5)               ; QUANTITY RECEIVED
  1.  S ACRQACP=$$SSX(X,"DT",6,6)               ; QUANTITY ACCEPTED
  1.  I ACRQACP=""!(ACRQACP=0) S ACRQRCD=0      ; REMOVE FALSE RECEIVED
  1.  S ACRAPD=""                               ; AMOUNT PAID
  1.  S ACRQDI=$$SSX(X,"DT",14,14)              ; QUANTITY DUE IN
  1.  S PRGPTR=$$LOCB(DPTR)                     ; POINTER TO FMS LOCB/PROG
  1.  S ACRDESC=$$IDESC(X)                      ; ITEM DESCRIPTION TEXT
  1.  S ACRDEPT=$$PRG(PRGPTR)                   ; DEPT NAME
  1.  S ACRDLCOD=$$LCODN(DPTR)
  1.  Q
  1. CAN(X) ;
  1.  N CAN0,DFLT,SHIP,MAIL,DFLT2,CLCOD,CLOC,CLOCPTR,ACRTYPE
  1.  S (ACRMAIL,ACRSHIP,CLOCNAM)=""
  1.  S ACRTYPE=$P(ACRCORE,U,2)       ;DOC-TYPE
  1.  Q:'X
  1.  S CAN0=$G(^ACRCAN(X,0))
  1.  S DFLT=$G(^ACRCAN(X,"DFLT"))
  1.  S SHIP=$P(DFLT,U,11)                  ;'SHIP TO' DEPT/PRG PTR
  1.  S MAIL=$P(DFLT,U,12)                  ;'MAIL INV TO' DEPT/PRG PTR
  1.  I ACRTYPE="TN" D
  1.  .S DFLT2=$G(^ACRCAN(X,"DFLT2"))
  1.  .S:SHIP="" SHIP=$P(DFLT2,U,2)         ;'TRAINING OFFICE' DEPT/PRG PTR
  1.  .S:MAIL="" MAIL=$P(DFLT2,U,1)         ;'MAIL TRAINING INV TO' DEPT/PRG PTR
  1.  S:MAIL ACRMAIL=$$PRG(MAIL)
  1.  S:SHIP ACRSHIP=$$PRG(SHIP)
  1.  S CLCOD=$P(CAN0,U,7)                      ;CAN LOCATION CODE PTR ^AUTTLCOD
  1.  S CLCODN=$$LCODE(CLCOD)                   ;CAN LOCATION CODE NAME
  1.  S CLOC=$P(CAN0,U,17)                ;LOCATION PTR ^AUTTLOC
  1.  I CLOC D
  1.  .S CLOCPTR=$P($G(^AUTTLOC(CLOC,0)),U)      ;LOCATION NAME
  1.  .S:CLOCPTR CLOCNAM=$P($G(^DIC(4,CLOCPTR,0)),U)
  1.  Q
  1. ITEMSDHR(ARRAY,ACRCORE) ;EP -- FINDS ITEMS FROM FMS DOCUMENT HISTORY RECORDS FILE MATCH
  1.  ;
  1.  ;    ARRAY   =  ACRSTRING DATA _"@"_ACRZ_U_ACRCAN_U_ACROCC_U_ACRAMT_U_ACRIFIN
  1.  N Y,ACRUI,ACRITM,ACRUCST,ACRKW,ACRDEPT,ACRQTY,ACRCANDA,ACRSINO,ACRECST
  1.  N ACRDLCOD,ACRTMP,ACRZ,ACRDESC,ACRMAIL,ACRSHIP,CLOCNAM,CLCODN,ACRCST
  1.  S ACRDOC=$P(ARRAY,U)
  1.  S ACRTMP=$P(ARRAY,"@",2)
  1.  S ACRZ=$P(ACRTMP,U)
  1.  S ACRCAN=$P(ACRTMP,U,2)
  1.  S ACROCC=$P(ACRTMP,U,3)
  1.  S ACRCST=$P(ACRTMP,U,4)
  1.  S ACRI=$E($P(ACRTMP,U,6),3)                     ;REVERSE CODE
  1.  S ACRECST=$$DOL^ACRFUFMU(ACRCST,0)
  1.  S ACRUCST=$$DOL^ACRFUFMU(ACRCST,ACRI)           ; DOLLAR AMOUNT
  1.  S ACRIFIN=$P(ACRTMP,U,5)
  1.  S ACRCANDA=$O(^AUTTCAN("B",ACRCAN,0))
  1.  S ACROCCDA=$O(^AUTTOBJC("C",ACROCC,0))
  1.  D CAN(ACRCANDA)
  1.  S ACRDESC=$$DESC11(ACROCCDA)
  1.  D RRDEF                                    ;SET DEFAULTS
  1.  D SET(ACRZ)
  1.  Q
  1. ITEMS11(ARRAY) ;EP -- FINDS ITEMS FROM 1166 APPROVALS FOR PAYMENT FILE MATCH
  1.  ;
  1.  ;    ARRAY   =  ACRSTRING DATA _"@"_ POINTER TO 1166 FILE
  1.  ;
  1.  N Y,ACRUI,ACRITM,ACRUCST,ACRKW,ACRDEPT,ACRQTY,ACRCANDA,ACRSINO,ACRECST
  1.  N ACRDLCOD,ACRTMP,ACRDESC,ACRMAIL,ACRSHIP,CLOCNAM,CLCODN,ACRI
  1.  D 112
  1.  S ACRIFIN=$S(ACRI="05":"OBLIGATION",ACRI="18":"PARTIAL INVOICE",ACRI="19":"FINAL INVOICE",1:ACRTCOD)
  1.  D CAN(ACRCANDA)
  1.  S ACRDESC=$$DESC11(ACROCCDA)
  1.  D RRDEF                              ;DEFAULTS
  1.  D SET(FY_BATCH_SEQ)
  1.  Q
  1.  ; *********************************
  1. 112 ; CALLED BY ITEMS AND ITEMS11
  1.  S ACRDOC=$P(ARRAY,U)
  1.  S ACRTMP=$P(ARRAY,"@",2)
  1.  S FY=$P(ACRTMP,U,1)
  1.  S BATCH=$P(ACRTMP,U,2)
  1.  S SEQ=$P(ACRTMP,U,3)
  1.  S ACRTMP=^AFSLAFP(FY,1,BATCH,1,SEQ,0)
  1.  S ACRCANDA=$P(ACRTMP,U,7)
  1.  S ACROCCDA=$P(ACRTMP,U,8)
  1.  S ACRTCOD=$P(ACRTMP,U,18)            ;TRANSACTION CODE
  1.  S ACRI=$E(ACRTCOD,1,2)               ;OBL OR PAYMENT
  1.  S ACRREV=$E(ACRTCOD,3)               ;REVERSAL CODE
  1.  S ACRAPD=+$P(ACRTMP,U,11)            ;AMOUNT PAID
  1.  S:$G(ACRECST)="" ACRECST=ACRAPD
  1.  S:$G(ACRUCST)="" ACRUCST=ACRAPD
  1.  S:ACRREV=2 ACRAPD="-"_ACRAPD         ;MAKE IT NEGATIVE IF REVERSAL = 2
  1.  Q
  1.  ;*****************************
  1. DESC11(OCC) ;----- RETURNS DESCRIPTION LINES 1-5
  1.  ;
  1.  ;      OCC  =  OBJECT CLASS CODE IEN
  1.  N DESC,OCCN,OCCDA
  1.  S DESC="UNKNOWN"
  1.  I 'OCC Q DESC
  1.  S OCCN=$P($G(^AUTTOBJC(OCC,0)),U,3)            ;GET OCC SHORT NAME
  1.  I OCCN="" D
  1.  .S OCCDA=$P($G(^AUTTOBJC(OCC,0)),U,2)
  1.  .I OCCDA S OCCN=$P($G(^AUTTOCG(OCCDA,0)),U,2)  ;GET OCC GROUP NAME
  1.  Q OCCN
  1.  ; ********************************************
  1. SET(Z) ;
  1.  N STR1,STR2,STR3
  1.  S $P(STR1,U,1)=ACRITM                      ; 1; ITEM NUMBER IN DOCUMENT
  1.  S $P(STR1,U,2)=ACRUI                       ; 2; UNIT OF ISSUE
  1.  S $P(STR1,U,3)=ACRQTY                      ; 3; QUANTITY
  1.  S $P(STR1,U,4)=ACRUCST                     ; 4; UNIT COST
  1.  S $P(STR1,U,5)=ACRECST                     ; 5; ESTIMATED COST
  1.  S $P(STR1,U,6)=ACRQRCD                     ; 6; QUANTITY RECEIVED
  1.  S $P(STR1,U,7)=ACRQACP                     ; 7; QUANTITY ACCEPTED
  1.  S $P(STR1,U,8)=ACRQDI                      ; 8; QUANTITY DUE IN
  1.  S $P(STR1,U,9)=ACRRQR                      ; 9; RR QUANTITY RECEIVED
  1.  S $P(STR1,U,10)=ACRRQA                     ;10; RR QUANTITY ACCEPTED
  1.  S $P(STR1,U,11)=ACRRIQ                     ;11; RR INVOICE QUANTITY
  1.  S $P(STR1,U,12)=ACRAPD                     ;12; AMOUNT PAID
  1.  S $P(STR1,U,13)=ACRRFIN                    ;13; FINAL/PARTIAL RR
  1.  S $P(STR1,U,14)=ACRIFIN                    ;14; FINAL/PARTIAL INV 
  1.  ;
  1.  S $P(STR2,U,1)=$E(ACRDESC,1,240)           ; 1; LINE DESCRIPTION
  1.  S $P(STR2,U,2)=ACRKW_U                     ; 2; KEYWORD
  1.  S $P(STR2,U,3)=ACRSINO                     ; 3; ARMS STANDARD ITEM NUMBER
  1.  ;
  1.  S $P(STR3,U,1)=ACRDESC                     ; 1; ITEM DESCRIPTION
  1.  S $P(STR3,U,2)=ACRMAIL                     ; 2; CAN MAIL INVOICE TO LOCATION
  1.  S $P(STR3,U,3)=ACRSHIP                     ; 3; CAN SHIP TO LOCATION
  1.  S $P(STR3,U,4)=ACRDEPT                     ; 4; DEPARTMENT NAME
  1.  S $P(STR3,U,5)=ACRDLCOD                    ; 5; DEPARTMENT LOCATION CODE NAME
  1.  S $P(STR3,U,6)=CLOCNAM                     ; 6; CAN LOCATION
  1.  S $P(STR3,U,7)=CLCODN                      ; 7; CAN LOC CODE NAME
  1.  S STR1=ACRCORE_U_STR1
  1.  Q:$D(^ACRZ("ITEMS",ACRCDOC,Z))             ; ALREADY RECORDED
  1.  S ^ACRZ("ITEMS",ACRCDOC,Z,1)=STR1
  1.  S ^ACRZ("ITEMS",ACRCDOC,Z,2)=STR2
  1.  S ^ACRZ("ITEMS",ACRCDOC,Z,3)=STR3
  1.  S ^ACRZ("ITEMS","TOTAL")=$G(^ACRZ("ITEMS","TOTAL"))+1
  1.  Q
  1.  ;********************************************************
  1. IDESC(X) ;----- RETURNS DESCRIPTION LINES 1-5
  1.  ;
  1.  ;      X  =  ITEM IEN
  1.  N NOTE,DESC,OCC,OCCN,OCCDA
  1.  S (DESC,NOTE)=""
  1.  I 'X Q DESC
  1.  S DESC=$$SSX(X,"DESC",1,5)
  1.  S NOTE=$$SSX(X,"NOTES",1,5)
  1.  I DESC]"" D
  1.  .S:NOTE]"" DESC=DESC_"; "_NOTE
  1.  .S DESC=$TR(DESC,U," ")
  1.  I DESC']"" D
  1.  .S OCC=$$SSX(X,0,4,4)                    ;GET OCC IEN FROM SS
  1.  .S OCCN=$$DESC11(OCC)                    ;GET OCC SHORT NAME
  1.  .S:OCCN]"" DESC=OCCN
  1.  Q DESC
  1.  ;*************************************************************
  1. UI(X) ;----- RETURNS UNIT OF ISSUE   
  1.  ;
  1.  ;      X  =  ITEM IEN
  1.  ;
  1.  N Y
  1.  S Y=""
  1.  I X S Y=$P($G(^ACRSS(X,"DT")),U,2)
  1.  I Y S Y=$P($G(^ACRUI(Y,0)),U)
  1.  Q Y
  1.  ; *************************************************************
  1. ECOST(X) ;----- RETURNS ESTIMATED COST
  1.  ;
  1.  ;      X  =  ITEM IEN
  1.  ;
  1.  N Y
  1.  S Y=""
  1.  I X S Y=$P($G(^ACRSS(X,"DT")),U,4)
  1.  Q Y
  1.  ; *************************************************************
  1. LCOD(X) ;EP -- RETURNS EXTERNAL LOCATION CODE
  1.  ;
  1.  ;      X  =  LOCATION CODE IEN
  1.  ;
  1.  N Y
  1.  S Y=""
  1.  I X S Y=$P($G(^AUTTLCOD(X,0)),U)
  1.  Q Y
  1.  ; *************************************************************
  1. LOCNM(X) ;EP -- RETURNS EXTERNAL LOCATION NAME
  1.  ;      X  =  LOCATION IEN
  1.  ;
  1.  N Y
  1.  S Y=""
  1.  I X S Y=$P($G(^DIC(4,X,0)),U)
  1.  Q Y
  1.  ;***************************************************************
  1. LCODE(X) ;EP -- RETURNS LOCATION CODE NAME
  1.  N Y
  1.  S Y=""
  1.  I X S Y=$P($G(^AUTTLCOD(X,0)),U,2)      ;LOCATION CODE NAME
  1.  Q Y
  1.  ;***************************************************************
  1. LCODN(X) ;EP -- RETURNS LOCATION CODE NAME OF DEPARTMENT ACCOUNT
  1.  ;
  1.  ;      X  =  FMS DEPARTMENT ACCOUNT IEN
  1.  ;
  1.  N Y
  1.  S Y=""
  1.  I X S Y=$P($G(^ACRLOCB(X,"DT")),U,11)         ;LOCATION CODE POINTER
  1.  I Y S Y=$$LCODE(Y)                            ;LOCATION CODE NAME
  1.  Q Y
  1.  ;***************************************************************
  1. RR(X) ; -- RETRIEVES RECEIVING REPORT DATA
  1.  ;         X = FMS SUPPLIES AND SERVICES IEN
  1.  ;
  1.  S ACRRDA=$O(^ACRRR("B",X,0))
  1.  S ACRIFIN="NO INVOICE"
  1.  S ACRRFIN="NO RR"
  1.  I 'ACRRDA D  Q                                ;NO RECEIVING REPORT
  1.  .S (ACRRQR,ACRRQA,ACRRIQ,ACRRIUC)=0
  1.  .S:ACRID["CANCEL" (ACRRFIN,ACRIFIN)="CANCELLED"
  1.  S ACRRR0=$G(^ACRRR(ACRRDA,0))
  1.  S ACRRFIN=$S($P(ACRRR0,U,8)=1:"FINAL RR",2:"PARTIAL RR",1:"NO RR")
  1.  S ACRIFIN=$S($P(ACRRR0,U,11)=1:"FINAL INV",2:"PARTIAL INV",1:"NO INVOICE")
  1.  S ACRRDT=$G(^ACRRR(ACRRDA,"DT"))
  1.  S ACRRUC=$P(ACRRDT,U)                ;UNIT COST
  1.  S ACRRQR=$P(ACRRDT,U,2)              ;QUANTITY RECEIVED
  1.  S ACRRQA=$P(ACRRDT,U,3)              ;QUANTITY ACCEPTED
  1.  I ACRRQA=""!(ACRRQA=0) S ACRRQR=0    ;REMOVE FALSE RECEIVED
  1.  S ACRRIUC=$P(ACRRDT,U,5)             ;INVOICE UNIT COST
  1.  S ACRRIQ=$P(ACRRDT,U,6)              ;INVOICE QUANTITY
  1.  S ACRRIV=$P(ACRRDT,U,7)              ;INVOICE NUMBER
  1.  Q
  1.  ; **************************************************************
  1. RRDEF ;RECEIVING REPORT DEFAULTS
  1.  S (ACRSINO,ACRKW,ACRDEPT,ACRDLCOD,ACRUI)=""
  1.  S (ACRRQR,ACRRQA,ACRRIQ,ACRAPD)=0           ;RECEIVING REPORT DEFAULTS
  1.  S (ACRQTY,ACRQRCD,ACRQACP,ACRITM)=0         ;SUPPLIES & SERVICES DEFAULTS
  1.  S ACRQDI=1
  1.  S ACRRFIN="NO RR"
  1.  I ACRIFIN'["OBLIGATION" D
  1.  .S (ACRQTY,ACRQRCD,ACRQACP,ACRITM)=1
  1.  .S (ACRRQR,ACRRQA,ACRRIQ)=1                 ;RECEIVING REPORT DEFAULTS
  1.  .S ACRUI="USD"
  1.  .S ACRQDI=$S(ACRIFIN["FINAL":0,1:1)         ;SET DUE IN TO 0 IF FINAL
  1.  .S (ACRAPD,ACRRIUC)=ACRUCST                          ;INVOICE UNIT COST
  1.  Q