- 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 Mar 13, 2025@21:13:01 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
