PRCHJS01 ;OI&T/KCL - IFCAP/ECMS INTERFACE TRANSMIT 2237 TO ECMS;6/12/12
;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23
;Per VHA Directive 2004-38, this routine should not be modified.
;
SEND2237(PRC410R,PRCERR) ;Send 2237 to eCMS via HL7 messaging
;This function is the primary driver for retrieving and sending
;a 2237 transaction to eCMS in single HL7 message (OMN^O07).
;
;This function will:
; - Retrieve 2237 data elements and place them into a work global
; - Perform 2237 pre-validation checks on 2237 data elements
; - Build and transmit 2237 data via OMN^O07 message
;
; Input:
; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
;
; Output:
; Function value - ien of msg in HLO MESSAGES (#778) file on success, 0 on failure
; PRCERR - (optional) on failure, an error msg array is returned, pass by ref
; Error msg array format:
; PRCERR(1)
; PRCERR(2)
; PRCERR(3), etc.
;
N PRCWORK ;name of work global containing the 2237 data elements
N PRCRSLT ;function result
;
;init temp work global
S PRCWORK=$NA(^TMP("PRCHJ2237",$J))
K @PRCWORK
;
S PRCRSLT=0
;
D ;drops out of DO block on failure
. ;
. ;get 2237 data elements and place into work global
. I '$$GET2237(PRC410R,PRCWORK,.PRCERR) S PRCERR(1)=$G(PRCERR) Q
. ;
. ;perform 2237 pre-validation checks on 2237 data elements
. I '$$PRE2237(PRCWORK,.PRCERR) Q
. ;
. ;build and transmit 2237 data via OMN^O07 message
. S PRCRSLT=$$OMNO07^PRCHJS04(PRCWORK,.PRCERR)
. I $G(PRCERR)]"" S PRCERR(1)=$G(PRCERR)
;
;cleanup work global
K @PRCWORK
;
Q PRCRSLT
;
;
GET2237(PRC410R,PRCWRK,PRCERR) ;Retrieve 2237 data elements
;This function is responsible for retrieving the 2237 data
;elements from the IFCAP database that will be transmitted
;to eCMS. The 2237 data elements will be placed into a temp
;work global.
;
; Input:
; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
; PRCWRK - (required) name of work global used to hold 2237 data elements
; Ex) S PRCWORK=$NA(^TMP("PRCHJ2237",$J))
;
; Output:
; Function value - 1 on success, 0 on failure
; PRCERR - (optional) on failure, an error message is returned, pass by ref
;
N PRCRSLT ;function result
;
S PRCRSLT=0
;
D ;drops out of DO block on failure
. ;
. ;get CONTROL POINT ACTIVITY (#410) data
. I '$$GET410^PRCHJS02(PRC410R,PRCWRK,.PRCERR) Q
. ;
. ;get 2237 line item data
. I '$$GETITEMS^PRCHJS02(PRC410R,PRCWRK,.PRCERR) Q
. ;
. ;get REQUEST WORKSHEET (#443) data
. I '$$GET443^PRCHJS03($P($G(@PRCWRK@("TRANUM")),U),PRCWRK,.PRCERR) Q
. ;
. ;if INVENTORY DISTRIBUTION POINT, then get GENERIC INVENTORY (#445) data
. I +$G(@PRCWRK@("INVDIS"))>0 D Q:$G(PRCERR)
. . I '$$GET445^PRCHJS03(+$G(@PRCWRK@("INVDIS")),PRCWRK,.PRCERR) Q
. ;
. ;if VENDOR POINTER, then get VENDOR (#440) data
. I +$G(@PRCWRK@("VENDPT"))>0 D Q:$G(PRCERR)
. . I '$$GET440^PRCHJS03(+$G(@PRCWRK@("VENDPT")),PRCWRK,.PRCERR) Q
. ;
. ;success
. S PRCRSLT=1
;
Q PRCRSLT
;
;
PRE2237(PRCWRK,PRCER) ;Pre-validate 2237 data elements
;This function performs pre-validation checks on specified
;2237 data elements being transmitted to eCMS.
;
; Input:
; PRCWRK - (required) name of work global containing 2237 data elements
;
; Output:
; Function value - returns 1 if all validation checks passed, 0 otherwise
; PRCER - (optional) on failure, an error msg array is returned, pass by ref
; Error msg array format:
; PRCER(1)
; PRCER(2)
; PRCER(3), etc.
;
N PRCSUB ;array subscript
N PRCLINE ;array subscript for items
N PRCITEML ;Line Item #
N PRCNUM ;array subscript for item description
N PRCIDX ;error array index
N PRCRSLT ;function result
;
S (PRCIDX,PRCRSLT)=0
;
D
. ;make sure this is a 2237
. I ($P($G(@PRCWRK@("FRMTYP")),U)<2)!($P($G(@PRCWRK@("FRMTYP")),U)>4) S PRCER(PRCIDX+1)="This is not a 2237 transaction" Q
. ;
. ;check for 2237 null field values (eCMS required fields)
. F PRCSUB="TRANUM","STANUM","RQSTDT","REQ","DTREQ","APOF","RQSRV","CTRLPT","COMMIT","ACTDATA" D
. . I $P($G(@PRCWRK@(PRCSUB)),U)="" D
. . . S PRCIDX=PRCIDX+1
. . . S PRCER(PRCIDX)="Field "_$$GET1^DID(410,$$FIELD(PRCSUB),"","LABEL")_" is missing"
. ;
. ;loop thru Line Items on 2237 and check for null field values (eCMS required fields)
. S PRCLINE=0
. F S PRCLINE=$O(@PRCWRK@(PRCLINE)) Q:'PRCLINE D
. . S PRCITEML=+$G(@PRCWRK@(PRCLINE,"ITLINE")) ;line item #
. . ;check for null fields
. . F PRCSUB="ITLINE","ITQTY","ITUOP","ITBOC","ITCOST" D
. . . I $P($G(@PRCWRK@(PRCLINE,PRCSUB)),U)="" D
. . . . S PRCIDX=PRCIDX+1
. . . . S PRCER(PRCIDX)="Line item ("_PRCITEML_") field "_$$GET1^DID(410.02,$$FIELD(PRCSUB),"","LABEL")_" is missing."
. . ;
. . ;check for line item description
. . I +$G(@PRCWRK@(PRCLINE,"ITDESC"))'>0 D
. . . S PRCIDX=PRCIDX+1
. . . S PRCER(PRCIDX)="Line item ("_PRCITEML_") field "_$$GET1^DID(410.02,$$FIELD("ITDESC"),"","LABEL")_" is missing."
. ;
. ;quit if error(s)
. Q:$G(PRCIDX)
. ;
. ;otherwise success
. S PRCRSLT=1
;
Q PRCRSLT
;
;
FIELD(PRCSUB) ;Return field number for subscript
;This function takes a given subscript in the 2237 work
;global and returns the corresponding field number.
;
; Input:
; PRCSUB - (required) subscript of 2237 work global
;
; Output:
; Function value - returns corresponding field number for subscript,
; null otherwise
;
N PRCFLD ;function result
S PRCFLD=""
;
D ;drops out of DO block once field # is determined
. ;
. ;CONTROL POINT ACTIVITY (#410) fields
. I PRCSUB="TRANUM" S PRCFLD=.01 Q
. I PRCSUB="STANUM" S PRCFLD=.5 Q
. I PRCSUB="RQSTDT" S PRCFLD=5 Q
. I PRCSUB="REQ" S PRCFLD=40 Q
. I PRCSUB="DTREQ" S PRCFLD=7 Q
. I PRCSUB="APOF" S PRCFLD=42 Q
. I PRCSUB="RQSRV" S PRCFLD=6.3 Q
. I PRCSUB="CTRLPT" S PRCFLD=15 Q
. I PRCSUB="COMMIT" S PRCFLD=20 Q
. I PRCSUB="ACTDATA" S PRCFLD=28 Q
. ;
. ;ITEM (#410.02) multiple fields
. I PRCSUB="ITLINE" S PRCFLD=.01 Q
. I PRCSUB="ITDESC" S PRCFLD=1 Q
. I PRCSUB="ITQTY" S PRCFLD=2 Q
. I PRCSUB="ITUOP" S PRCFLD=3 Q
. I PRCSUB="ITBOC" S PRCFLD=4 Q
. I PRCSUB="ITCOST" S PRCFLD=7 Q
;
Q PRCFLD
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHJS01 6555 printed Apr 09, 2024@21:01:48 Page 2
PRCHJS01 ;OI&T/KCL - IFCAP/ECMS INTERFACE TRANSMIT 2237 TO ECMS;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 ;
SEND2237(PRC410R,PRCERR) ;Send 2237 to eCMS via HL7 messaging
+1 ;This function is the primary driver for retrieving and sending
+2 ;a 2237 transaction to eCMS in single HL7 message (OMN^O07).
+3 ;
+4 ;This function will:
+5 ; - Retrieve 2237 data elements and place them into a work global
+6 ; - Perform 2237 pre-validation checks on 2237 data elements
+7 ; - Build and transmit 2237 data via OMN^O07 message
+8 ;
+9 ; Input:
+10 ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
+11 ;
+12 ; Output:
+13 ; Function value - ien of msg in HLO MESSAGES (#778) file on success, 0 on failure
+14 ; PRCERR - (optional) on failure, an error msg array is returned, pass by ref
+15 ; Error msg array format:
+16 ; PRCERR(1)
+17 ; PRCERR(2)
+18 ; PRCERR(3), etc.
+19 ;
+20 ;name of work global containing the 2237 data elements
NEW PRCWORK
+21 ;function result
NEW PRCRSLT
+22 ;
+23 ;init temp work global
+24 SET PRCWORK=$NAME(^TMP("PRCHJ2237",$JOB))
+25 KILL @PRCWORK
+26 ;
+27 SET PRCRSLT=0
+28 ;
+29 ;drops out of DO block on failure
Begin DoDot:1
+30 ;
+31 ;get 2237 data elements and place into work global
+32 IF '$$GET2237(PRC410R,PRCWORK,.PRCERR)
SET PRCERR(1)=$GET(PRCERR)
QUIT
+33 ;
+34 ;perform 2237 pre-validation checks on 2237 data elements
+35 IF '$$PRE2237(PRCWORK,.PRCERR)
QUIT
+36 ;
+37 ;build and transmit 2237 data via OMN^O07 message
+38 SET PRCRSLT=$$OMNO07^PRCHJS04(PRCWORK,.PRCERR)
+39 IF $GET(PRCERR)]""
SET PRCERR(1)=$GET(PRCERR)
End DoDot:1
+40 ;
+41 ;cleanup work global
+42 KILL @PRCWORK
+43 ;
+44 QUIT PRCRSLT
+45 ;
+46 ;
GET2237(PRC410R,PRCWRK,PRCERR) ;Retrieve 2237 data elements
+1 ;This function is responsible for retrieving the 2237 data
+2 ;elements from the IFCAP database that will be transmitted
+3 ;to eCMS. The 2237 data elements will be placed into a temp
+4 ;work global.
+5 ;
+6 ; Input:
+7 ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
+8 ; PRCWRK - (required) name of work global used to hold 2237 data elements
+9 ; Ex) S PRCWORK=$NA(^TMP("PRCHJ2237",$J))
+10 ;
+11 ; Output:
+12 ; Function value - 1 on success, 0 on failure
+13 ; PRCERR - (optional) on failure, an error message is returned, pass by ref
+14 ;
+15 ;function result
NEW PRCRSLT
+16 ;
+17 SET PRCRSLT=0
+18 ;
+19 ;drops out of DO block on failure
Begin DoDot:1
+20 ;
+21 ;get CONTROL POINT ACTIVITY (#410) data
+22 IF '$$GET410^PRCHJS02(PRC410R,PRCWRK,.PRCERR)
QUIT
+23 ;
+24 ;get 2237 line item data
+25 IF '$$GETITEMS^PRCHJS02(PRC410R,PRCWRK,.PRCERR)
QUIT
+26 ;
+27 ;get REQUEST WORKSHEET (#443) data
+28 IF '$$GET443^PRCHJS03($PIECE($GET(@PRCWRK@("TRANUM")),U),PRCWRK,.PRCERR)
QUIT
+29 ;
+30 ;if INVENTORY DISTRIBUTION POINT, then get GENERIC INVENTORY (#445) data
+31 IF +$GET(@PRCWRK@("INVDIS"))>0
Begin DoDot:2
+32 IF '$$GET445^PRCHJS03(+$GET(@PRCWRK@("INVDIS")),PRCWRK,.PRCERR)
QUIT
End DoDot:2
if $GET(PRCERR)
QUIT
+33 ;
+34 ;if VENDOR POINTER, then get VENDOR (#440) data
+35 IF +$GET(@PRCWRK@("VENDPT"))>0
Begin DoDot:2
+36 IF '$$GET440^PRCHJS03(+$GET(@PRCWRK@("VENDPT")),PRCWRK,.PRCERR)
QUIT
End DoDot:2
if $GET(PRCERR)
QUIT
+37 ;
+38 ;success
+39 SET PRCRSLT=1
End DoDot:1
+40 ;
+41 QUIT PRCRSLT
+42 ;
+43 ;
PRE2237(PRCWRK,PRCER) ;Pre-validate 2237 data elements
+1 ;This function performs pre-validation checks on specified
+2 ;2237 data elements being transmitted to eCMS.
+3 ;
+4 ; Input:
+5 ; PRCWRK - (required) name of work global containing 2237 data elements
+6 ;
+7 ; Output:
+8 ; Function value - returns 1 if all validation checks passed, 0 otherwise
+9 ; PRCER - (optional) on failure, an error msg array is returned, pass by ref
+10 ; Error msg array format:
+11 ; PRCER(1)
+12 ; PRCER(2)
+13 ; PRCER(3), etc.
+14 ;
+15 ;array subscript
NEW PRCSUB
+16 ;array subscript for items
NEW PRCLINE
+17 ;Line Item #
NEW PRCITEML
+18 ;array subscript for item description
NEW PRCNUM
+19 ;error array index
NEW PRCIDX
+20 ;function result
NEW PRCRSLT
+21 ;
+22 SET (PRCIDX,PRCRSLT)=0
+23 ;
+24 Begin DoDot:1
+25 ;make sure this is a 2237
+26 IF ($PIECE($GET(@PRCWRK@("FRMTYP")),U)<2)!($PIECE($GET(@PRCWRK@("FRMTYP")),U)>4)
SET PRCER(PRCIDX+1)="This is not a 2237 transaction"
QUIT
+27 ;
+28 ;check for 2237 null field values (eCMS required fields)
+29 FOR PRCSUB="TRANUM","STANUM","RQSTDT","REQ","DTREQ","APOF","RQSRV","CTRLPT","COMMIT","ACTDATA"
Begin DoDot:2
+30 IF $PIECE($GET(@PRCWRK@(PRCSUB)),U)=""
Begin DoDot:3
+31 SET PRCIDX=PRCIDX+1
+32 SET PRCER(PRCIDX)="Field "_$$GET1^DID(410,$$FIELD(PRCSUB),"","LABEL")_" is missing"
End DoDot:3
End DoDot:2
+33 ;
+34 ;loop thru Line Items on 2237 and check for null field values (eCMS required fields)
+35 SET PRCLINE=0
+36 FOR
SET PRCLINE=$ORDER(@PRCWRK@(PRCLINE))
if 'PRCLINE
QUIT
Begin DoDot:2
+37 ;line item #
SET PRCITEML=+$GET(@PRCWRK@(PRCLINE,"ITLINE"))
+38 ;check for null fields
+39 FOR PRCSUB="ITLINE","ITQTY","ITUOP","ITBOC","ITCOST"
Begin DoDot:3
+40 IF $PIECE($GET(@PRCWRK@(PRCLINE,PRCSUB)),U)=""
Begin DoDot:4
+41 SET PRCIDX=PRCIDX+1
+42 SET PRCER(PRCIDX)="Line item ("_PRCITEML_") field "_$$GET1^DID(410.02,$$FIELD(PRCSUB),"","LABEL")_" is missing."
End DoDot:4
End DoDot:3
+43 ;
+44 ;check for line item description
+45 IF +$GET(@PRCWRK@(PRCLINE,"ITDESC"))'>0
Begin DoDot:3
+46 SET PRCIDX=PRCIDX+1
+47 SET PRCER(PRCIDX)="Line item ("_PRCITEML_") field "_$$GET1^DID(410.02,$$FIELD("ITDESC"),"","LABEL")_" is missing."
End DoDot:3
End DoDot:2
+48 ;
+49 ;quit if error(s)
+50 if $GET(PRCIDX)
QUIT
+51 ;
+52 ;otherwise success
+53 SET PRCRSLT=1
End DoDot:1
+54 ;
+55 QUIT PRCRSLT
+56 ;
+57 ;
FIELD(PRCSUB) ;Return field number for subscript
+1 ;This function takes a given subscript in the 2237 work
+2 ;global and returns the corresponding field number.
+3 ;
+4 ; Input:
+5 ; PRCSUB - (required) subscript of 2237 work global
+6 ;
+7 ; Output:
+8 ; Function value - returns corresponding field number for subscript,
+9 ; null otherwise
+10 ;
+11 ;function result
NEW PRCFLD
+12 SET PRCFLD=""
+13 ;
+14 ;drops out of DO block once field # is determined
Begin DoDot:1
+15 ;
+16 ;CONTROL POINT ACTIVITY (#410) fields
+17 IF PRCSUB="TRANUM"
SET PRCFLD=.01
QUIT
+18 IF PRCSUB="STANUM"
SET PRCFLD=.5
QUIT
+19 IF PRCSUB="RQSTDT"
SET PRCFLD=5
QUIT
+20 IF PRCSUB="REQ"
SET PRCFLD=40
QUIT
+21 IF PRCSUB="DTREQ"
SET PRCFLD=7
QUIT
+22 IF PRCSUB="APOF"
SET PRCFLD=42
QUIT
+23 IF PRCSUB="RQSRV"
SET PRCFLD=6.3
QUIT
+24 IF PRCSUB="CTRLPT"
SET PRCFLD=15
QUIT
+25 IF PRCSUB="COMMIT"
SET PRCFLD=20
QUIT
+26 IF PRCSUB="ACTDATA"
SET PRCFLD=28
QUIT
+27 ;
+28 ;ITEM (#410.02) multiple fields
+29 IF PRCSUB="ITLINE"
SET PRCFLD=.01
QUIT
+30 IF PRCSUB="ITDESC"
SET PRCFLD=1
QUIT
+31 IF PRCSUB="ITQTY"
SET PRCFLD=2
QUIT
+32 IF PRCSUB="ITUOP"
SET PRCFLD=3
QUIT
+33 IF PRCSUB="ITBOC"
SET PRCFLD=4
QUIT
+34 IF PRCSUB="ITCOST"
SET PRCFLD=7
QUIT
End DoDot:1
+35 ;
+36 QUIT PRCFLD
