PRCHJS02 ;OI&T/KCL - IFCAP/ECMS INTERFACE RETRIEVE 2237 DATA;6/12/12
;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23
;Per VHA Directive 2004-38, this routine should not be modified.
;
GET410(PRC410R,PRCWRK,PRCER) ;Get CONTROL POINT ACTIVITY (#410) data
;This function retrieves 2237 data elements from the CONTROL POINT
;ACTIVITY (#410) file and places them into a ^TMP work global. Data
;is placed into the work global in both internal and external format.
;
; Input:
; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
; PRCWRK - (required) name of work global containing data elements
;
; Output:
; Function value - 1 on success, 0 on failure
; PRCER - (optional) on failure, an error message is returned,
; pass by reference
; PRCWRK - work global containing the #410 data elements:
;
; Subscript Field# Data Element
; --------- ------ -------------------
; TRANUM .01 TRANSACTION NUMBER
; STANUM .5 STATION NUMBER
; FRMTYP 3 FORM TYPE
; INVDIS 4 INVENTORY DISTRIBUTION POINT
; RQSTDT 5 DATE OF REQUEST
; RQSRV 6.3 REQUESTING SERVICE
; DTREQ 7 DATE REQUIRED
; PRI 7.5 PRIORITY OF REQUEST
; REMARKS 9 SPECIAL REMARKS
; VENDNM 11 VENDOR
; VENDAD1 11.1 VENDOR ADDRESS1
; VENDAD2 11.2 VENDOR ADDRESS2
; VENDAD3 11.3 VENDOR ADDRESS3
; VENDAD4 11.4 VENDOR ADDRESS4
; VENDCTY 11.5 VENDOR CITY
; VENDST 11.6 VENDOR STATE
; VENDZIP 11.7 VENDOR ZIP
; VENDCON 11.8 VENDOR CONTACT
; VENDPH 11.9 VENDOR PHONE NUMBER
; VENDPT 12 VENDOR POINTER
; CTRLPT 15 CONTROL POINT
; COSTCTR 15.5 COST CENTER
; COMMIT 20 COMMITTED (ESTIMATED) COST
; COMMITDT 21 DATE COMMITTED
; TRANSAMT 27 TRANSACTION $ AMOUNT
; ACTDATA 28 ACCOUNTING DATA
; FCPPRJ 28.1 FCP/PRJ
; BBFY 28.5 BBFY
; REQ 40 REQUESTOR
; REQTITLE 41 REQUESTOR TITLE
; APOF 42 APPROVING OFFICIAL
; APOFTIT 43 APPROVING OFFICIAL TITLE
; ESIGDT 44.6 ES CODE DATE/TIME
; JUSTIF 45 JUSTIFICATION
; DELIVTO 46 DELIVER TO/LOCATION
; ESTSHIP 48.1 EST. SHIPPING
; COMMENT 60 COMMENTS
; SUBSTA 448 SUBSTATION
;
N PRCIENS ;iens string for GETS^DIQ
N PRCFLDS ;results array for GETS^DIQ
N PRCERR ;error array for GETS^DIQ
N PRCRSLT ;function result
;
S PRCRSLT=0
S PRCER="Control Point Activity record not found"
;
I $G(PRC410R)>0,$D(^PRCS(410,PRC410R)) D
. ;retrieve data from #410 top level fields
. S PRCIENS=PRC410R_","
. D GETS^DIQ(410,PRCIENS,"*","IE","PRCFLDS","PRCERR")
. I $D(PRCERR) S PRCER="Unable to retrieve Control Point Activity record" Q
. ;
. ;place top level (#410) fields into work global
. S @PRCWRK@("TRANUM")=$G(PRCFLDS(410,PRCIENS,.01,"I"))_U_$G(PRCFLDS(410,PRCIENS,.01,"E"))
. S @PRCWRK@("STANUM")=$G(PRCFLDS(410,PRCIENS,.5,"I"))_U_$G(PRCFLDS(410,PRCIENS,.5,"E"))
. S @PRCWRK@("FRMTYP")=$G(PRCFLDS(410,PRCIENS,3,"I"))_U_$G(PRCFLDS(410,PRCIENS,3,"E"))
. S @PRCWRK@("INVDIS")=$G(PRCFLDS(410,PRCIENS,4,"I"))_U_$G(PRCFLDS(410,PRCIENS,4,"E"))
. S @PRCWRK@("RQSTDT")=$G(PRCFLDS(410,PRCIENS,5,"I"))_U_$G(PRCFLDS(410,PRCIENS,5,"E"))
. S @PRCWRK@("RQSRV")=$G(PRCFLDS(410,PRCIENS,6.3,"I"))_U_$G(PRCFLDS(410,PRCIENS,6.3,"E"))
. S @PRCWRK@("DTREQ")=$G(PRCFLDS(410,PRCIENS,7,"I"))_U_$G(PRCFLDS(410,PRCIENS,7,"E"))
. S @PRCWRK@("PRI")=$G(PRCFLDS(410,PRCIENS,7.5,"I"))_U_$G(PRCFLDS(410,PRCIENS,7.5,"E"))
. S @PRCWRK@("VENDNM")=$G(PRCFLDS(410,PRCIENS,11,"I"))_U_$G(PRCFLDS(410,PRCIENS,11,"E"))
. S @PRCWRK@("VENDAD1")=$G(PRCFLDS(410,PRCIENS,11.1,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.1,"E"))
. S @PRCWRK@("VENDAD2")=$G(PRCFLDS(410,PRCIENS,11.2,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.2,"E"))
. S @PRCWRK@("VENDAD3")=$G(PRCFLDS(410,PRCIENS,11.3,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.3,"E"))
. S @PRCWRK@("VENDAD4")=$G(PRCFLDS(410,PRCIENS,11.4,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.4,"E"))
. S @PRCWRK@("VENDCTY")=$G(PRCFLDS(410,PRCIENS,11.5,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.5,"E"))
. S @PRCWRK@("VENDST")=$G(PRCFLDS(410,PRCIENS,11.6,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.6,"E"))
. S @PRCWRK@("VENDZIP")=$G(PRCFLDS(410,PRCIENS,11.7,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.7,"E"))
. S @PRCWRK@("VENDCON")=$G(PRCFLDS(410,PRCIENS,11.8,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.8,"E"))
. S @PRCWRK@("VENDPH")=$G(PRCFLDS(410,PRCIENS,11.9,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.9,"E"))
. S @PRCWRK@("VENDPT")=$G(PRCFLDS(410,PRCIENS,12,"I"))_U_$G(PRCFLDS(410,PRCIENS,12,"E"))
. S @PRCWRK@("CTRLPT")=$G(PRCFLDS(410,PRCIENS,15,"I"))_U_$G(PRCFLDS(410,PRCIENS,15,"E"))
. S @PRCWRK@("COSTCTR")=$G(PRCFLDS(410,PRCIENS,15.5,"I"))_U_$G(PRCFLDS(410,PRCIENS,15.5,"E"))
. S @PRCWRK@("COMMIT")=$G(PRCFLDS(410,PRCIENS,20,"I"))_U_$G(PRCFLDS(410,PRCIENS,20,"E"))
. S @PRCWRK@("COMMITDT")=$G(PRCFLDS(410,PRCIENS,21,"I"))_U_$G(PRCFLDS(410,PRCIENS,21,"E"))
. S @PRCWRK@("TRANSAMT")=$G(PRCFLDS(410,PRCIENS,27,"I"))_U_$G(PRCFLDS(410,PRCIENS,27,"E"))
. S @PRCWRK@("ACTDATA")=$G(PRCFLDS(410,PRCIENS,28,"I"))_U_$G(PRCFLDS(410,PRCIENS,28,"E"))
. S @PRCWRK@("FCPPRJ")=$G(PRCFLDS(410,PRCIENS,28.1,"I"))_U_$G(PRCFLDS(410,PRCIENS,28.1,"E"))
. S @PRCWRK@("BBFY")=$G(PRCFLDS(410,PRCIENS,28.5,"I"))_U_$G(PRCFLDS(410,PRCIENS,28.5,"E"))
. S @PRCWRK@("REQ")=$G(PRCFLDS(410,PRCIENS,40,"I"))_U_$G(PRCFLDS(410,PRCIENS,40,"E"))
. S @PRCWRK@("REQTITLE")=$G(PRCFLDS(410,PRCIENS,41,"I"))_U_$G(PRCFLDS(410,PRCIENS,41,"E"))
. S @PRCWRK@("APOF")=$G(PRCFLDS(410,PRCIENS,42,"I"))_U_$G(PRCFLDS(410,PRCIENS,42,"E"))
. S @PRCWRK@("APOFTIT")=$G(PRCFLDS(410,PRCIENS,43,"I"))_U_$G(PRCFLDS(410,PRCIENS,43,"E"))
. S @PRCWRK@("ESIGDT")=$G(PRCFLDS(410,PRCIENS,44.6,"I"))_U_$G(PRCFLDS(410,PRCIENS,44.6,"E"))
. S @PRCWRK@("DELIVTO")=$G(PRCFLDS(410,PRCIENS,46,"I"))_U_$G(PRCFLDS(410,PRCIENS,46,"E"))
. S @PRCWRK@("ESTSHIP")=$G(PRCFLDS(410,PRCIENS,48.1,"I"))_U_$G(PRCFLDS(410,PRCIENS,48.1,"E"))
. S @PRCWRK@("SUBSTA")=$G(PRCFLDS(410,PRCIENS,448,"I"))_U_$G(PRCFLDS(410,PRCIENS,448,"E"))
. ;
. ;retrieve Special Remarks WP field and place into work global
. D FORMTXT($G(PRC410R),PRCWRK,"REMARKS","RM")
. ;
. ;retrieve Justification WP field and place into work global
. D FORMTXT($G(PRC410R),PRCWRK,"JUSTIF",8)
. ;
. ;retrieve Comments WP field and place into work global
. D FORMTXT($G(PRC410R),PRCWRK,"COMMENT","CO")
. ;
. ;success
. S PRCRSLT=1 K PRCER
;
Q PRCRSLT
;
;
FORMTXT(PRC410R,PRCWRK,PRCSUB,PRCNODE,PRCWL,PRCWR) ;Format WP Text Utility
;This procedure is used to format Word Processing fields
;retrieved from the CONTROL POINT ACTIVITY (#410) file and
;place them into the ^TMP work global containing 2237 data elements.
;
; Input:
; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
; PRCWRK - (required) name of work global containing 2237 data elements
; PRCSUB - (required) work global subscript where text will be placed
; PRCNODE - (required) node where WP fields reside in (#410) file
; PRCWL - (optional) left margin for WP text, default=1
; PRCWR - (optional) right margin for WP text, default=200
;
; Output: None
;
N X ;string of text to be added as input to the formatter
N DIWL ;left margin for text
N DIWR ;right margin for text
N DIWF ;string of format control parameters
N PRCI ;WP nodes subscript
;
;input params for ^DIWP
S DIWL=$S($G(PRCWL)>0:PRCWL,1:1)
S DIWR=$S($G(PRCWR)>0:PRCWR,1:200)
S (DIWF,X)=""
K ^UTILITY($J,"W") ;must kill before calling ^DIWP
;
;retrieve WP text and place formatted text into ^UTILITY($J,"W")
S PRCI=0
F S PRCI=$O(^PRCS(410,$G(PRC410R),PRCNODE,PRCI)) Q:PRCI="" D
. S X=$G(^PRCS(410,$G(PRC410R),PRCNODE,PRCI,0))
. D ^DIWP
;
;merge formatted text into work global
I $D(^UTILITY($J,"W")) M @PRCWRK@(PRCSUB)=^UTILITY($J,"W",1)
;
;cleanup
K ^UTILITY($J,"W")
Q
;
;
GETITEMS(PRC410R,PRCWRK,PRCER) ;Get 2237 line items
;This function retrieves 2237 line item data elements
;and places them into a ^TMP work global. Data is placed
;into the work global in both internal and external format.
;
; Input:
; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
; PRCWRK - (required) name of work global containing data elements
;
; Output:
; Function value - 1 on success, 0 on failure
; PRCER - (optional) on failure, an error message is returned,
; pass by reference
; PRCWRK - work global containing the line item data elements:
;
; Subscript Field# Data Element
; --------- ------ -------------------
; ITEM (#410.02) multiple:
; line_item#,ITLINE .01 LINE ITEM NUMBER
; line_item#,ITDESC 1 DESCRIPTION
; line_item#,ITQTY 2 QUANTITY
; line_item#,ITUOP 3 UNIT OF PURCHASE
; line_item#,ITBOC 4 BOC
; line_item#,ITMFN 5 ITEM MASTER FILE NO.
; line_item#,ITSTOCK 6 STOCK NUMBER
; line_item#,ITCOST 7 EST. ITEM (UNIT) COST
; line_item#,ITDMID 17 DM DOC ID
;
; DELIVERY SCHEDULE (#410.6) file:
; (Note: An item may have multiple delivery schedules)
; line_item#,delivery_schedule#,DELREF .01 REFERENCE
; line_item#,delivery_schedule#,DELDT 1 DELIVERY DATE
; line_item#,delivery_schedule#,DELLOC 2 LOCATION
; line_item#,delivery_schedule#,DELQTY 3 QTY TO BE DELIVERED
;
; UNIT OF ISSUE (#420.5):
; line_item#,UNITNM .01 NAME
; line_item#,UNITFNM 1 FULL NAME
;
; ITEM MASTER (#441) file:
; line_item#,IMNSN 5 NSN
; line_item#,IMFSC 2 FSC
; line_item#,IMMFG 19 MFG PART NO.
; line_item#,IMFOOD 20 FOOD GROUP
; line_item#,IMNIF 51 NIF ITEM NUMBER
;
; VENDOR (#441.01) multiple:
; line_item#,IMPKGM 1.6 PACKAGING MULTIPLE
; line_item#,IMCTRCT 2 CONTRACT
; line_item#,IMEXPDT 2.2 CONTRACT EXP. DATE
; line_item#,IMNDC 4 NDC
; line_item#,IMMIN 8 MINIMUM ORDER QTY
; line_item#,IMMAX 8.5 MAXIMUM ORDER QTY
; line_item#,IMREQ 9 REQUIRED ORDER MULTIPLE
; line_item#,IMUCF 10 UNIT CONVERSION FACTOR
;
N PRCIENS,PRC4106,PRC4205,PRC441 ;iens string for GETS^DIQ
N PRCFLDS,PRCDS,PRCUNIT,PRCIMF ;results array for GETS^DIQ
N PRCERR ;error array for GETS^DIQ
N PRCLINE ;line item #
N PRCITIEN ;ien of record in Item subfile
N PRCI ;item Description node subscript
N PRCITM ;item multiple subscript
N PRCSUB1,PRCSUB2 ;file #410 global subscripts
N PRCRSLT ;function result
;
S PRCRSLT=0
S PRCER="Control Point Activity record not found"
;
I $G(PRC410R)'>0 Q PRCRSLT
I '$D(^PRCS(410,PRC410R)) Q PRCRSLT
;
;retrieve all fields and records in #410.02,10 multiple and place in ^TMP global
S PRCIENS=PRC410R_","
S PRCFLDS=$NA(^TMP("PRCHJITEM",$J)) K @PRCFLDS
D GETS^DIQ(410,PRCIENS,"10*","IE",PRCFLDS,"PRCERR")
I $D(PRCERR) S PRCER="Unable to retrieve line item data" Q PRCRSLT
;
;place line item fields into work global
S PRCITM=""
F S PRCITM=$O(@PRCFLDS@(410.02,PRCITM)) Q:PRCITM="" D
. S PRCLINE=+$G(@PRCFLDS@(410.02,PRCITM,.01,"I"))
. S @PRCWRK@(PRCLINE,"ITLINE")=$G(@PRCFLDS@(410.02,PRCITM,.01,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,.01,"E"))
. S @PRCWRK@(PRCLINE,"ITQTY")=$G(@PRCFLDS@(410.02,PRCITM,2,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,2,"E"))
. S @PRCWRK@(PRCLINE,"ITUOP")=$G(@PRCFLDS@(410.02,PRCITM,3,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,3,"E"))
. S @PRCWRK@(PRCLINE,"ITBOC")=$G(@PRCFLDS@(410.02,PRCITM,4,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,4,"E"))
. S @PRCWRK@(PRCLINE,"ITMFN")=$G(@PRCFLDS@(410.02,PRCITM,5,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,5,"E"))
. S @PRCWRK@(PRCLINE,"ITSTOCK")=$G(@PRCFLDS@(410.02,PRCITM,6,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,6,"E"))
. S @PRCWRK@(PRCLINE,"ITCOST")=$G(@PRCFLDS@(410.02,PRCITM,7,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,7,"E"))
. S @PRCWRK@(PRCLINE,"ITDMID")=$G(@PRCFLDS@(410.02,PRCITM,17,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,17,"E"))
. ;
. ;resolve Line Item Number to Item entry's ien
. S PRCITIEN=+$O(^PRCS(410,PRC410R,"IT","B",PRCLINE,0))
. ;
. ;place Item Description WP field into work global
. N DIWL,DIWR,DIWF,X ;^DIWP input params
. S DIWL=1,DIWR=200,DIWF="",PRCI=0
. K ^UTILITY($J,"W") ;must kill before calling ^DIWP
. ;loop thru Item Description nodes and place formatted text into ^UTILITY($J,"W")
. F S PRCI=$O(^PRCS(410,$G(PRC410R),"IT",PRCITIEN,1,PRCI)) Q:PRCI="" D
. . S X=$G(^PRCS(410,$G(PRC410R),"IT",PRCITIEN,1,PRCI,0)) D ^DIWP
. ;merge formatted text into work global
. I $D(^UTILITY($J,"W")) M @PRCWRK@(PRCLINE,"ITDESC")=^UTILITY($J,"W",1)
. K ^UTILITY($J,"W")
. ;
. ;for each item, place DELIVERY SCHEDULE (#410.6) fields into work global
. S (PRCSUB1,PRCSUB2)=""
. F S PRCSUB1=$O(^PRCS(410,PRC410R,"IT",+PRCITM,2,"B",PRCSUB1)) Q:PRCSUB1="" D
. . S PRCSUB2=$O(^PRCS(410,PRC410R,"IT",+PRCITM,2,"B",PRCSUB1,PRCSUB2))
. . Q:$G(PRCSUB2)'>0
. . S PRC4106=$P($G(^PRCS(410,+$G(PRC410R),"IT",+PRCITM,2,PRCSUB2,0)),U,2)_"," ;ptr to #410.6
. . K PRCDS
. . I +PRC4106>0 D GETS^DIQ(410.6,PRC4106,"*","IE","PRCDS","PRCERR")
. . Q:$D(PRCERR)
. . S @PRCWRK@(PRCLINE,PRCSUB1,"DELREF")=$G(PRCDS(410.6,PRC4106,.01,"I"))_U_$G(PRCDS(410.6,PRC4106,.01,"E"))
. . S @PRCWRK@(PRCLINE,PRCSUB1,"DELDT")=$G(PRCDS(410.6,PRC4106,1,"I"))_U_$G(PRCDS(410.6,PRC4106,1,"E"))
. . S @PRCWRK@(PRCLINE,PRCSUB1,"DELLOC")=$G(PRCDS(410.6,PRC4106,2,"I"))_U_$G(PRCDS(410.6,PRC4106,2,"E"))
. . S @PRCWRK@(PRCLINE,PRCSUB1,"DELQTY")=$G(PRCDS(410.6,PRC4106,3,"I"))_U_$G(PRCDS(410.6,PRC4106,3,"E"))
. ;
. ;quit if error encountered
. Q:$D(PRCERR)
. ;
. ;for each item, place UNIT OF ISSUE (#420.5) fields into work global
. S PRC4205=+$G(@PRCWRK@(PRCLINE,"ITUOP"))_","
. K PRCUNIT
. I +PRC4205>0 D GETS^DIQ(420.5,PRC4205,"*","IE","PRCUNIT","PRCERR")
. I $D(PRCERR) S PRCER="Unable to retrieve Unit Of Issue record" Q
. S @PRCWRK@(PRCLINE,"UNITNM")=$G(PRCUNIT(420.5,PRC4205,.01,"I"))_U_$G(PRCUNIT(420.5,PRC4205,.01,"E"))
. S @PRCWRK@(PRCLINE,"UNITFNM")=$G(PRCUNIT(420.5,PRC4205,1,"I"))_U_$G(PRCUNIT(420.5,PRC4205,1,"E"))
. ;
. ;for each item, place ITEM MASTER (#441) fields into work global
. S PRC441=+$G(@PRCWRK@(PRCLINE,"ITMFN"))_","
. K PRCIMF
. I +PRC441>0 D GETS^DIQ(441,PRC441,"**","IE","PRCIMF","PRCERR")
. I $D(PRCERR) S PRCER="Unable to retrieve Item Master record" Q
. S @PRCWRK@(PRCLINE,"IMFSC")=$G(PRCIMF(441,PRC441,2,"I"))_U_$G(PRCIMF(441,PRC441,2,"E"))
. S @PRCWRK@(PRCLINE,"IMNSN")=$G(PRCIMF(441,PRC441,5,"I"))_U_$G(PRCIMF(441,PRC441,5,"E"))
. S @PRCWRK@(PRCLINE,"IMMFG")=$G(PRCIMF(441,PRC441,19,"I"))_U_$G(PRCIMF(441,PRC441,19,"E"))
. S @PRCWRK@(PRCLINE,"IMFOOD")=$G(PRCIMF(441,PRC441,20,"I"))_U_$G(PRCIMF(441,PRC441,20,"E"))
. S @PRCWRK@(PRCLINE,"IMNIF")=$G(PRCIMF(441,PRC441,51,"I"))_U_$G(PRCIMF(441,PRC441,51,"E"))
. ;
. ;use Vendor ptr (#12) field of (#410) file to obtain the associated
. ;VENDOR (#441.01) sub-file record and place field into work global
. S PRC441=$$GET1^DIQ(410,PRC410R_",",12,"I")_","_PRC441
. S @PRCWRK@(PRCLINE,"IMPKGM")=$G(PRCIMF(441.01,PRC441,1.6,"I"))_U_$G(PRCIMF(441.01,PRC441,1.6,"E"))
. S @PRCWRK@(PRCLINE,"IMCTRCT")=$G(PRCIMF(441.01,PRC441,2,"I"))_U_$G(PRCIMF(441.01,PRC441,2,"E"))
. S @PRCWRK@(PRCLINE,"IMEXPDT")=$G(PRCIMF(441.01,PRC441,2.2,"I"))_U_$G(PRCIMF(441.01,PRC441,2.2,"E"))
. ;need to convert computed field CONTRACT EXP. DATE to internal FM date format
. I $P(@PRCWRK@(PRCLINE,"IMEXPDT"),U)]"" D
. . N X,Y ;input/output vars for ^%DT
. . S X=$P(@PRCWRK@(PRCLINE,"IMEXPDT"),U)
. . D ^%DT
. . S $P(@PRCWRK@(PRCLINE,"IMEXPDT"),U)=$S(Y>0:Y,1:"")
. S @PRCWRK@(PRCLINE,"IMNDC")=$G(PRCIMF(441.01,PRC441,4,"I"))_U_$G(PRCIMF(441.01,PRC441,4,"E"))
. S @PRCWRK@(PRCLINE,"IMMIN")=$G(PRCIMF(441.01,PRC441,8,"I"))_U_$G(PRCIMF(441.01,PRC441,8,"E"))
. S @PRCWRK@(PRCLINE,"IMMAX")=$G(PRCIMF(441.01,PRC441,8.5,"I"))_U_$G(PRCIMF(441.01,PRC441,8.5,"E"))
. S @PRCWRK@(PRCLINE,"IMREQ")=$G(PRCIMF(441.01,PRC441,9,"I"))_U_$G(PRCIMF(441.01,PRC441,9,"E"))
. S @PRCWRK@(PRCLINE,"IMUCF")=$G(PRCIMF(441.01,PRC441,10,"I"))_U_$G(PRCIMF(441.01,PRC441,10,"E"))
;
;cleanup ^TMP global
K @PRCFLDS
;
;success
S PRCRSLT=1 K PRCER
;
Q PRCRSLT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHJS02 17444 printed Oct 16, 2024@18:09 Page 2
PRCHJS02 ;OI&T/KCL - IFCAP/ECMS INTERFACE RETRIEVE 2237 DATA;6/12/12
+1 ;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23
+2 ;Per VHA Directive 2004-38, this routine should not be modified.
+3 ;
GET410(PRC410R,PRCWRK,PRCER) ;Get CONTROL POINT ACTIVITY (#410) data
+1 ;This function retrieves 2237 data elements from the CONTROL POINT
+2 ;ACTIVITY (#410) file and places them into a ^TMP work global. Data
+3 ;is placed into the work global in both internal and external format.
+4 ;
+5 ; Input:
+6 ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
+7 ; PRCWRK - (required) name of work global containing data elements
+8 ;
+9 ; Output:
+10 ; Function value - 1 on success, 0 on failure
+11 ; PRCER - (optional) on failure, an error message is returned,
+12 ; pass by reference
+13 ; PRCWRK - work global containing the #410 data elements:
+14 ;
+15 ; Subscript Field# Data Element
+16 ; --------- ------ -------------------
+17 ; TRANUM .01 TRANSACTION NUMBER
+18 ; STANUM .5 STATION NUMBER
+19 ; FRMTYP 3 FORM TYPE
+20 ; INVDIS 4 INVENTORY DISTRIBUTION POINT
+21 ; RQSTDT 5 DATE OF REQUEST
+22 ; RQSRV 6.3 REQUESTING SERVICE
+23 ; DTREQ 7 DATE REQUIRED
+24 ; PRI 7.5 PRIORITY OF REQUEST
+25 ; REMARKS 9 SPECIAL REMARKS
+26 ; VENDNM 11 VENDOR
+27 ; VENDAD1 11.1 VENDOR ADDRESS1
+28 ; VENDAD2 11.2 VENDOR ADDRESS2
+29 ; VENDAD3 11.3 VENDOR ADDRESS3
+30 ; VENDAD4 11.4 VENDOR ADDRESS4
+31 ; VENDCTY 11.5 VENDOR CITY
+32 ; VENDST 11.6 VENDOR STATE
+33 ; VENDZIP 11.7 VENDOR ZIP
+34 ; VENDCON 11.8 VENDOR CONTACT
+35 ; VENDPH 11.9 VENDOR PHONE NUMBER
+36 ; VENDPT 12 VENDOR POINTER
+37 ; CTRLPT 15 CONTROL POINT
+38 ; COSTCTR 15.5 COST CENTER
+39 ; COMMIT 20 COMMITTED (ESTIMATED) COST
+40 ; COMMITDT 21 DATE COMMITTED
+41 ; TRANSAMT 27 TRANSACTION $ AMOUNT
+42 ; ACTDATA 28 ACCOUNTING DATA
+43 ; FCPPRJ 28.1 FCP/PRJ
+44 ; BBFY 28.5 BBFY
+45 ; REQ 40 REQUESTOR
+46 ; REQTITLE 41 REQUESTOR TITLE
+47 ; APOF 42 APPROVING OFFICIAL
+48 ; APOFTIT 43 APPROVING OFFICIAL TITLE
+49 ; ESIGDT 44.6 ES CODE DATE/TIME
+50 ; JUSTIF 45 JUSTIFICATION
+51 ; DELIVTO 46 DELIVER TO/LOCATION
+52 ; ESTSHIP 48.1 EST. SHIPPING
+53 ; COMMENT 60 COMMENTS
+54 ; SUBSTA 448 SUBSTATION
+55 ;
+56 ;iens string for GETS^DIQ
NEW PRCIENS
+57 ;results array for GETS^DIQ
NEW PRCFLDS
+58 ;error array for GETS^DIQ
NEW PRCERR
+59 ;function result
NEW PRCRSLT
+60 ;
+61 SET PRCRSLT=0
+62 SET PRCER="Control Point Activity record not found"
+63 ;
+64 IF $GET(PRC410R)>0
IF $DATA(^PRCS(410,PRC410R))
Begin DoDot:1
+65 ;retrieve data from #410 top level fields
+66 SET PRCIENS=PRC410R_","
+67 DO GETS^DIQ(410,PRCIENS,"*","IE","PRCFLDS","PRCERR")
+68 IF $DATA(PRCERR)
SET PRCER="Unable to retrieve Control Point Activity record"
QUIT
+69 ;
+70 ;place top level (#410) fields into work global
+71 SET @PRCWRK@("TRANUM")=$GET(PRCFLDS(410,PRCIENS,.01,"I"))_U_$GET(PRCFLDS(410,PRCIENS,.01,"E"))
+72 SET @PRCWRK@("STANUM")=$GET(PRCFLDS(410,PRCIENS,.5,"I"))_U_$GET(PRCFLDS(410,PRCIENS,.5,"E"))
+73 SET @PRCWRK@("FRMTYP")=$GET(PRCFLDS(410,PRCIENS,3,"I"))_U_$GET(PRCFLDS(410,PRCIENS,3,"E"))
+74 SET @PRCWRK@("INVDIS")=$GET(PRCFLDS(410,PRCIENS,4,"I"))_U_$GET(PRCFLDS(410,PRCIENS,4,"E"))
+75 SET @PRCWRK@("RQSTDT")=$GET(PRCFLDS(410,PRCIENS,5,"I"))_U_$GET(PRCFLDS(410,PRCIENS,5,"E"))
+76 SET @PRCWRK@("RQSRV")=$GET(PRCFLDS(410,PRCIENS,6.3,"I"))_U_$GET(PRCFLDS(410,PRCIENS,6.3,"E"))
+77 SET @PRCWRK@("DTREQ")=$GET(PRCFLDS(410,PRCIENS,7,"I"))_U_$GET(PRCFLDS(410,PRCIENS,7,"E"))
+78 SET @PRCWRK@("PRI")=$GET(PRCFLDS(410,PRCIENS,7.5,"I"))_U_$GET(PRCFLDS(410,PRCIENS,7.5,"E"))
+79 SET @PRCWRK@("VENDNM")=$GET(PRCFLDS(410,PRCIENS,11,"I"))_U_$GET(PRCFLDS(410,PRCIENS,11,"E"))
+80 SET @PRCWRK@("VENDAD1")=$GET(PRCFLDS(410,PRCIENS,11.1,"I"))_U_$GET(PRCFLDS(410,PRCIENS,11.1,"E"))
+81 SET @PRCWRK@("VENDAD2")=$GET(PRCFLDS(410,PRCIENS,11.2,"I"))_U_$GET(PRCFLDS(410,PRCIENS,11.2,"E"))
+82 SET @PRCWRK@("VENDAD3")=$GET(PRCFLDS(410,PRCIENS,11.3,"I"))_U_$GET(PRCFLDS(410,PRCIENS,11.3,"E"))
+83 SET @PRCWRK@("VENDAD4")=$GET(PRCFLDS(410,PRCIENS,11.4,"I"))_U_$GET(PRCFLDS(410,PRCIENS,11.4,"E"))
+84 SET @PRCWRK@("VENDCTY")=$GET(PRCFLDS(410,PRCIENS,11.5,"I"))_U_$GET(PRCFLDS(410,PRCIENS,11.5,"E"))
+85 SET @PRCWRK@("VENDST")=$GET(PRCFLDS(410,PRCIENS,11.6,"I"))_U_$GET(PRCFLDS(410,PRCIENS,11.6,"E"))
+86 SET @PRCWRK@("VENDZIP")=$GET(PRCFLDS(410,PRCIENS,11.7,"I"))_U_$GET(PRCFLDS(410,PRCIENS,11.7,"E"))
+87 SET @PRCWRK@("VENDCON")=$GET(PRCFLDS(410,PRCIENS,11.8,"I"))_U_$GET(PRCFLDS(410,PRCIENS,11.8,"E"))
+88 SET @PRCWRK@("VENDPH")=$GET(PRCFLDS(410,PRCIENS,11.9,"I"))_U_$GET(PRCFLDS(410,PRCIENS,11.9,"E"))
+89 SET @PRCWRK@("VENDPT")=$GET(PRCFLDS(410,PRCIENS,12,"I"))_U_$GET(PRCFLDS(410,PRCIENS,12,"E"))
+90 SET @PRCWRK@("CTRLPT")=$GET(PRCFLDS(410,PRCIENS,15,"I"))_U_$GET(PRCFLDS(410,PRCIENS,15,"E"))
+91 SET @PRCWRK@("COSTCTR")=$GET(PRCFLDS(410,PRCIENS,15.5,"I"))_U_$GET(PRCFLDS(410,PRCIENS,15.5,"E"))
+92 SET @PRCWRK@("COMMIT")=$GET(PRCFLDS(410,PRCIENS,20,"I"))_U_$GET(PRCFLDS(410,PRCIENS,20,"E"))
+93 SET @PRCWRK@("COMMITDT")=$GET(PRCFLDS(410,PRCIENS,21,"I"))_U_$GET(PRCFLDS(410,PRCIENS,21,"E"))
+94 SET @PRCWRK@("TRANSAMT")=$GET(PRCFLDS(410,PRCIENS,27,"I"))_U_$GET(PRCFLDS(410,PRCIENS,27,"E"))
+95 SET @PRCWRK@("ACTDATA")=$GET(PRCFLDS(410,PRCIENS,28,"I"))_U_$GET(PRCFLDS(410,PRCIENS,28,"E"))
+96 SET @PRCWRK@("FCPPRJ")=$GET(PRCFLDS(410,PRCIENS,28.1,"I"))_U_$GET(PRCFLDS(410,PRCIENS,28.1,"E"))
+97 SET @PRCWRK@("BBFY")=$GET(PRCFLDS(410,PRCIENS,28.5,"I"))_U_$GET(PRCFLDS(410,PRCIENS,28.5,"E"))
+98 SET @PRCWRK@("REQ")=$GET(PRCFLDS(410,PRCIENS,40,"I"))_U_$GET(PRCFLDS(410,PRCIENS,40,"E"))
+99 SET @PRCWRK@("REQTITLE")=$GET(PRCFLDS(410,PRCIENS,41,"I"))_U_$GET(PRCFLDS(410,PRCIENS,41,"E"))
+100 SET @PRCWRK@("APOF")=$GET(PRCFLDS(410,PRCIENS,42,"I"))_U_$GET(PRCFLDS(410,PRCIENS,42,"E"))
+101 SET @PRCWRK@("APOFTIT")=$GET(PRCFLDS(410,PRCIENS,43,"I"))_U_$GET(PRCFLDS(410,PRCIENS,43,"E"))
+102 SET @PRCWRK@("ESIGDT")=$GET(PRCFLDS(410,PRCIENS,44.6,"I"))_U_$GET(PRCFLDS(410,PRCIENS,44.6,"E"))
+103 SET @PRCWRK@("DELIVTO")=$GET(PRCFLDS(410,PRCIENS,46,"I"))_U_$GET(PRCFLDS(410,PRCIENS,46,"E"))
+104 SET @PRCWRK@("ESTSHIP")=$GET(PRCFLDS(410,PRCIENS,48.1,"I"))_U_$GET(PRCFLDS(410,PRCIENS,48.1,"E"))
+105 SET @PRCWRK@("SUBSTA")=$GET(PRCFLDS(410,PRCIENS,448,"I"))_U_$GET(PRCFLDS(410,PRCIENS,448,"E"))
+106 ;
+107 ;retrieve Special Remarks WP field and place into work global
+108 DO FORMTXT($GET(PRC410R),PRCWRK,"REMARKS","RM")
+109 ;
+110 ;retrieve Justification WP field and place into work global
+111 DO FORMTXT($GET(PRC410R),PRCWRK,"JUSTIF",8)
+112 ;
+113 ;retrieve Comments WP field and place into work global
+114 DO FORMTXT($GET(PRC410R),PRCWRK,"COMMENT","CO")
+115 ;
+116 ;success
+117 SET PRCRSLT=1
KILL PRCER
End DoDot:1
+118 ;
+119 QUIT PRCRSLT
+120 ;
+121 ;
FORMTXT(PRC410R,PRCWRK,PRCSUB,PRCNODE,PRCWL,PRCWR) ;Format WP Text Utility
+1 ;This procedure is used to format Word Processing fields
+2 ;retrieved from the CONTROL POINT ACTIVITY (#410) file and
+3 ;place them into the ^TMP work global containing 2237 data elements.
+4 ;
+5 ; Input:
+6 ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
+7 ; PRCWRK - (required) name of work global containing 2237 data elements
+8 ; PRCSUB - (required) work global subscript where text will be placed
+9 ; PRCNODE - (required) node where WP fields reside in (#410) file
+10 ; PRCWL - (optional) left margin for WP text, default=1
+11 ; PRCWR - (optional) right margin for WP text, default=200
+12 ;
+13 ; Output: None
+14 ;
+15 ;string of text to be added as input to the formatter
NEW X
+16 ;left margin for text
NEW DIWL
+17 ;right margin for text
NEW DIWR
+18 ;string of format control parameters
NEW DIWF
+19 ;WP nodes subscript
NEW PRCI
+20 ;
+21 ;input params for ^DIWP
+22 SET DIWL=$SELECT($GET(PRCWL)>0:PRCWL,1:1)
+23 SET DIWR=$SELECT($GET(PRCWR)>0:PRCWR,1:200)
+24 SET (DIWF,X)=""
+25 ;must kill before calling ^DIWP
KILL ^UTILITY($JOB,"W")
+26 ;
+27 ;retrieve WP text and place formatted text into ^UTILITY($J,"W")
+28 SET PRCI=0
+29 FOR
SET PRCI=$ORDER(^PRCS(410,$GET(PRC410R),PRCNODE,PRCI))
if PRCI=""
QUIT
Begin DoDot:1
+30 SET X=$GET(^PRCS(410,$GET(PRC410R),PRCNODE,PRCI,0))
+31 DO ^DIWP
End DoDot:1
+32 ;
+33 ;merge formatted text into work global
+34 IF $DATA(^UTILITY($JOB,"W"))
MERGE @PRCWRK@(PRCSUB)=^UTILITY($JOB,"W",1)
+35 ;
+36 ;cleanup
+37 KILL ^UTILITY($JOB,"W")
+38 QUIT
+39 ;
+40 ;
GETITEMS(PRC410R,PRCWRK,PRCER) ;Get 2237 line items
+1 ;This function retrieves 2237 line item data elements
+2 ;and places them into a ^TMP work global. Data is placed
+3 ;into the work global in both internal and external format.
+4 ;
+5 ; Input:
+6 ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
+7 ; PRCWRK - (required) name of work global containing data elements
+8 ;
+9 ; Output:
+10 ; Function value - 1 on success, 0 on failure
+11 ; PRCER - (optional) on failure, an error message is returned,
+12 ; pass by reference
+13 ; PRCWRK - work global containing the line item data elements:
+14 ;
+15 ; Subscript Field# Data Element
+16 ; --------- ------ -------------------
+17 ; ITEM (#410.02) multiple:
+18 ; line_item#,ITLINE .01 LINE ITEM NUMBER
+19 ; line_item#,ITDESC 1 DESCRIPTION
+20 ; line_item#,ITQTY 2 QUANTITY
+21 ; line_item#,ITUOP 3 UNIT OF PURCHASE
+22 ; line_item#,ITBOC 4 BOC
+23 ; line_item#,ITMFN 5 ITEM MASTER FILE NO.
+24 ; line_item#,ITSTOCK 6 STOCK NUMBER
+25 ; line_item#,ITCOST 7 EST. ITEM (UNIT) COST
+26 ; line_item#,ITDMID 17 DM DOC ID
+27 ;
+28 ; DELIVERY SCHEDULE (#410.6) file:
+29 ; (Note: An item may have multiple delivery schedules)
+30 ; line_item#,delivery_schedule#,DELREF .01 REFERENCE
+31 ; line_item#,delivery_schedule#,DELDT 1 DELIVERY DATE
+32 ; line_item#,delivery_schedule#,DELLOC 2 LOCATION
+33 ; line_item#,delivery_schedule#,DELQTY 3 QTY TO BE DELIVERED
+34 ;
+35 ; UNIT OF ISSUE (#420.5):
+36 ; line_item#,UNITNM .01 NAME
+37 ; line_item#,UNITFNM 1 FULL NAME
+38 ;
+39 ; ITEM MASTER (#441) file:
+40 ; line_item#,IMNSN 5 NSN
+41 ; line_item#,IMFSC 2 FSC
+42 ; line_item#,IMMFG 19 MFG PART NO.
+43 ; line_item#,IMFOOD 20 FOOD GROUP
+44 ; line_item#,IMNIF 51 NIF ITEM NUMBER
+45 ;
+46 ; VENDOR (#441.01) multiple:
+47 ; line_item#,IMPKGM 1.6 PACKAGING MULTIPLE
+48 ; line_item#,IMCTRCT 2 CONTRACT
+49 ; line_item#,IMEXPDT 2.2 CONTRACT EXP. DATE
+50 ; line_item#,IMNDC 4 NDC
+51 ; line_item#,IMMIN 8 MINIMUM ORDER QTY
+52 ; line_item#,IMMAX 8.5 MAXIMUM ORDER QTY
+53 ; line_item#,IMREQ 9 REQUIRED ORDER MULTIPLE
+54 ; line_item#,IMUCF 10 UNIT CONVERSION FACTOR
+55 ;
+56 ;iens string for GETS^DIQ
NEW PRCIENS,PRC4106,PRC4205,PRC441
+57 ;results array for GETS^DIQ
NEW PRCFLDS,PRCDS,PRCUNIT,PRCIMF
+58 ;error array for GETS^DIQ
NEW PRCERR
+59 ;line item #
NEW PRCLINE
+60 ;ien of record in Item subfile
NEW PRCITIEN
+61 ;item Description node subscript
NEW PRCI
+62 ;item multiple subscript
NEW PRCITM
+63 ;file #410 global subscripts
NEW PRCSUB1,PRCSUB2
+64 ;function result
NEW PRCRSLT
+65 ;
+66 SET PRCRSLT=0
+67 SET PRCER="Control Point Activity record not found"
+68 ;
+69 IF $GET(PRC410R)'>0
QUIT PRCRSLT
+70 IF '$DATA(^PRCS(410,PRC410R))
QUIT PRCRSLT
+71 ;
+72 ;retrieve all fields and records in #410.02,10 multiple and place in ^TMP global
+73 SET PRCIENS=PRC410R_","
+74 SET PRCFLDS=$NAME(^TMP("PRCHJITEM",$JOB))
KILL @PRCFLDS
+75 DO GETS^DIQ(410,PRCIENS,"10*","IE",PRCFLDS,"PRCERR")
+76 IF $DATA(PRCERR)
SET PRCER="Unable to retrieve line item data"
QUIT PRCRSLT
+77 ;
+78 ;place line item fields into work global
+79 SET PRCITM=""
+80 FOR
SET PRCITM=$ORDER(@PRCFLDS@(410.02,PRCITM))
if PRCITM=""
QUIT
Begin DoDot:1
+81 SET PRCLINE=+$GET(@PRCFLDS@(410.02,PRCITM,.01,"I"))
+82 SET @PRCWRK@(PRCLINE,"ITLINE")=$GET(@PRCFLDS@(410.02,PRCITM,.01,"I"))_U_$GET(@PRCFLDS@(410.02,PRCITM,.01,"E"))
+83 SET @PRCWRK@(PRCLINE,"ITQTY")=$GET(@PRCFLDS@(410.02,PRCITM,2,"I"))_U_$GET(@PRCFLDS@(410.02,PRCITM,2,"E"))
+84 SET @PRCWRK@(PRCLINE,"ITUOP")=$GET(@PRCFLDS@(410.02,PRCITM,3,"I"))_U_$GET(@PRCFLDS@(410.02,PRCITM,3,"E"))
+85 SET @PRCWRK@(PRCLINE,"ITBOC")=$GET(@PRCFLDS@(410.02,PRCITM,4,"I"))_U_$GET(@PRCFLDS@(410.02,PRCITM,4,"E"))
+86 SET @PRCWRK@(PRCLINE,"ITMFN")=$GET(@PRCFLDS@(410.02,PRCITM,5,"I"))_U_$GET(@PRCFLDS@(410.02,PRCITM,5,"E"))
+87 SET @PRCWRK@(PRCLINE,"ITSTOCK")=$GET(@PRCFLDS@(410.02,PRCITM,6,"I"))_U_$GET(@PRCFLDS@(410.02,PRCITM,6,"E"))
+88 SET @PRCWRK@(PRCLINE,"ITCOST")=$GET(@PRCFLDS@(410.02,PRCITM,7,"I"))_U_$GET(@PRCFLDS@(410.02,PRCITM,7,"E"))
+89 SET @PRCWRK@(PRCLINE,"ITDMID")=$GET(@PRCFLDS@(410.02,PRCITM,17,"I"))_U_$GET(@PRCFLDS@(410.02,PRCITM,17,"E"))
+90 ;
+91 ;resolve Line Item Number to Item entry's ien
+92 SET PRCITIEN=+$ORDER(^PRCS(410,PRC410R,"IT","B",PRCLINE,0))
+93 ;
+94 ;place Item Description WP field into work global
+95 ;^DIWP input params
NEW DIWL,DIWR,DIWF,X
+96 SET DIWL=1
SET DIWR=200
SET DIWF=""
SET PRCI=0
+97 ;must kill before calling ^DIWP
KILL ^UTILITY($JOB,"W")
+98 ;loop thru Item Description nodes and place formatted text into ^UTILITY($J,"W")
+99 FOR
SET PRCI=$ORDER(^PRCS(410,$GET(PRC410R),"IT",PRCITIEN,1,PRCI))
if PRCI=""
QUIT
Begin DoDot:2
+100 SET X=$GET(^PRCS(410,$GET(PRC410R),"IT",PRCITIEN,1,PRCI,0))
DO ^DIWP
End DoDot:2
+101 ;merge formatted text into work global
+102 IF $DATA(^UTILITY($JOB,"W"))
MERGE @PRCWRK@(PRCLINE,"ITDESC")=^UTILITY($JOB,"W",1)
+103 KILL ^UTILITY($JOB,"W")
+104 ;
+105 ;for each item, place DELIVERY SCHEDULE (#410.6) fields into work global
+106 SET (PRCSUB1,PRCSUB2)=""
+107 FOR
SET PRCSUB1=$ORDER(^PRCS(410,PRC410R,"IT",+PRCITM,2,"B",PRCSUB1))
if PRCSUB1=""
QUIT
Begin DoDot:2
+108 SET PRCSUB2=$ORDER(^PRCS(410,PRC410R,"IT",+PRCITM,2,"B",PRCSUB1,PRCSUB2))
+109 if $GET(PRCSUB2)'>0
QUIT
+110 ;ptr to #410.6
SET PRC4106=$PIECE($GET(^PRCS(410,+$GET(PRC410R),"IT",+PRCITM,2,PRCSUB2,0)),U,2)_","
+111 KILL PRCDS
+112 IF +PRC4106>0
DO GETS^DIQ(410.6,PRC4106,"*","IE","PRCDS","PRCERR")
+113 if $DATA(PRCERR)
QUIT
+114 SET @PRCWRK@(PRCLINE,PRCSUB1,"DELREF")=$GET(PRCDS(410.6,PRC4106,.01,"I"))_U_$GET(PRCDS(410.6,PRC4106,.01,"E"))
+115 SET @PRCWRK@(PRCLINE,PRCSUB1,"DELDT")=$GET(PRCDS(410.6,PRC4106,1,"I"))_U_$GET(PRCDS(410.6,PRC4106,1,"E"))
+116 SET @PRCWRK@(PRCLINE,PRCSUB1,"DELLOC")=$GET(PRCDS(410.6,PRC4106,2,"I"))_U_$GET(PRCDS(410.6,PRC4106,2,"E"))
+117 SET @PRCWRK@(PRCLINE,PRCSUB1,"DELQTY")=$GET(PRCDS(410.6,PRC4106,3,"I"))_U_$GET(PRCDS(410.6,PRC4106,3,"E"))
End DoDot:2
+118 ;
+119 ;quit if error encountered
+120 if $DATA(PRCERR)
QUIT
+121 ;
+122 ;for each item, place UNIT OF ISSUE (#420.5) fields into work global
+123 SET PRC4205=+$GET(@PRCWRK@(PRCLINE,"ITUOP"))_","
+124 KILL PRCUNIT
+125 IF +PRC4205>0
DO GETS^DIQ(420.5,PRC4205,"*","IE","PRCUNIT","PRCERR")
+126 IF $DATA(PRCERR)
SET PRCER="Unable to retrieve Unit Of Issue record"
QUIT
+127 SET @PRCWRK@(PRCLINE,"UNITNM")=$GET(PRCUNIT(420.5,PRC4205,.01,"I"))_U_$GET(PRCUNIT(420.5,PRC4205,.01,"E"))
+128 SET @PRCWRK@(PRCLINE,"UNITFNM")=$GET(PRCUNIT(420.5,PRC4205,1,"I"))_U_$GET(PRCUNIT(420.5,PRC4205,1,"E"))
+129 ;
+130 ;for each item, place ITEM MASTER (#441) fields into work global
+131 SET PRC441=+$GET(@PRCWRK@(PRCLINE,"ITMFN"))_","
+132 KILL PRCIMF
+133 IF +PRC441>0
DO GETS^DIQ(441,PRC441,"**","IE","PRCIMF","PRCERR")
+134 IF $DATA(PRCERR)
SET PRCER="Unable to retrieve Item Master record"
QUIT
+135 SET @PRCWRK@(PRCLINE,"IMFSC")=$GET(PRCIMF(441,PRC441,2,"I"))_U_$GET(PRCIMF(441,PRC441,2,"E"))
+136 SET @PRCWRK@(PRCLINE,"IMNSN")=$GET(PRCIMF(441,PRC441,5,"I"))_U_$GET(PRCIMF(441,PRC441,5,"E"))
+137 SET @PRCWRK@(PRCLINE,"IMMFG")=$GET(PRCIMF(441,PRC441,19,"I"))_U_$GET(PRCIMF(441,PRC441,19,"E"))
+138 SET @PRCWRK@(PRCLINE,"IMFOOD")=$GET(PRCIMF(441,PRC441,20,"I"))_U_$GET(PRCIMF(441,PRC441,20,"E"))
+139 SET @PRCWRK@(PRCLINE,"IMNIF")=$GET(PRCIMF(441,PRC441,51,"I"))_U_$GET(PRCIMF(441,PRC441,51,"E"))
+140 ;
+141 ;use Vendor ptr (#12) field of (#410) file to obtain the associated
+142 ;VENDOR (#441.01) sub-file record and place field into work global
+143 SET PRC441=$$GET1^DIQ(410,PRC410R_",",12,"I")_","_PRC441
+144 SET @PRCWRK@(PRCLINE,"IMPKGM")=$GET(PRCIMF(441.01,PRC441,1.6,"I"))_U_$GET(PRCIMF(441.01,PRC441,1.6,"E"))
+145 SET @PRCWRK@(PRCLINE,"IMCTRCT")=$GET(PRCIMF(441.01,PRC441,2,"I"))_U_$GET(PRCIMF(441.01,PRC441,2,"E"))
+146 SET @PRCWRK@(PRCLINE,"IMEXPDT")=$GET(PRCIMF(441.01,PRC441,2.2,"I"))_U_$GET(PRCIMF(441.01,PRC441,2.2,"E"))
+147 ;need to convert computed field CONTRACT EXP. DATE to internal FM date format
+148 IF $PIECE(@PRCWRK@(PRCLINE,"IMEXPDT"),U)]""
Begin DoDot:2
+149 ;input/output vars for ^%DT
NEW X,Y
+150 SET X=$PIECE(@PRCWRK@(PRCLINE,"IMEXPDT"),U)
+151 DO ^%DT
+152 SET $PIECE(@PRCWRK@(PRCLINE,"IMEXPDT"),U)=$SELECT(Y>0:Y,1:"")
End DoDot:2
+153 SET @PRCWRK@(PRCLINE,"IMNDC")=$GET(PRCIMF(441.01,PRC441,4,"I"))_U_$GET(PRCIMF(441.01,PRC441,4,"E"))
+154 SET @PRCWRK@(PRCLINE,"IMMIN")=$GET(PRCIMF(441.01,PRC441,8,"I"))_U_$GET(PRCIMF(441.01,PRC441,8,"E"))
+155 SET @PRCWRK@(PRCLINE,"IMMAX")=$GET(PRCIMF(441.01,PRC441,8.5,"I"))_U_$GET(PRCIMF(441.01,PRC441,8.5,"E"))
+156 SET @PRCWRK@(PRCLINE,"IMREQ")=$GET(PRCIMF(441.01,PRC441,9,"I"))_U_$GET(PRCIMF(441.01,PRC441,9,"E"))
+157 SET @PRCWRK@(PRCLINE,"IMUCF")=$GET(PRCIMF(441.01,PRC441,10,"I"))_U_$GET(PRCIMF(441.01,PRC441,10,"E"))
End DoDot:1
+158 ;
+159 ;cleanup ^TMP global
+160 KILL @PRCFLDS
+161 ;
+162 ;success
+163 SET PRCRSLT=1
KILL PRCER
+164 ;
+165 QUIT PRCRSLT
