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