- PRCHJUTL ;OI&T/LKG,KCL-UTILITY FUNCTIONS IFCAP/ECMS INTERFACE ;5/10/13 15:46
- ;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23
- ;Per VHA Directive 2004-38, this routine should not be modified.
- ;
- ;
- ECMS2237(PRCHJDA) ;Checks 2237 to see if processed in eCMS - Returns 1 if
- ;processed in eCMS and 0 if not. Check on basis of whether the ECMS
- ;ACTIONUID field is populated.
- N X S X=($P($G(^PRCS(410,PRCHJDA,1)),U,8)'="")
- Q X
- ;
- UPD443(PRC443R,PRCERR) ;Update file #443 record
- ;This function is used to update the following fields in
- ;a REQUEST WORKSHEET (#443) record:
- ;
- ; Field Name Field #
- ; ------------------- -------
- ; CURRENT STATUS 1.5
- ; ACCOUNTABLE OFFICER 2
- ; VALIDATION CODE 3
- ; ESIG DATE/TIME 4
- ;
- ; Input:
- ; PRC443R - (required) IEN of record in REQUEST WORKSHEET (#443) file
- ;
- ; Output:
- ; Function Value - returns 1 on success, 0 on failure
- ; PRCERR - (optional) on failure, an error message is returned,
- ; pass by ref
- ;
- N PRCRSLT ;function result
- N PRCIENS ;iens string for FM data array
- N PRCFDA ;FM data array
- ;
- S PRC443R=+$G(PRC443R)
- S PRCRSLT=0
- S PRCERR="Invalid input parameter"
- ;
- I PRC443R>0 D
- . K PRCERR
- . S PRCIENS=PRC443R_","
- . S PRCFDA(443,PRCIENS,1.5)=60 ;Pending Accountable Officer Sig.
- . S PRCFDA(443,PRCIENS,2)="@" ;delete
- . S PRCFDA(443,PRCIENS,3)="@" ;delete
- . S PRCFDA(443,PRCIENS,4)="@" ;delete
- . D FILE^DIE("K","PRCFDA","PRCERR")
- . ;quit if filing error
- . I $D(PRCERR) S PRCERR=$G(PRCERR("DIERR","1","TEXT",1)) Q
- . ;
- . ;success
- . S PRCRSLT=1
- ;
- Q PRCRSLT
- ;
- ;
- UPD410(PRC410R,PRCERR) ;Update file #410 record
- ;This function is used to update the following fields in
- ;a CONTROL POINT ACTIVITY (#410) record:
- ;
- ; Field Name Field #
- ; ------------------- -------
- ; ACCOUNTABLE OFFICER 39
- ; AO SIGNATURE DATE 69
- ;
- ; Input:
- ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
- ;
- ; Output:
- ; Function Value - returns 1 on success, 0 on failure
- ; PRCERR - (optional) on failure, an error message is returned,
- ; pass by ref
- ;
- N PRCRSLT ;function result
- N PRCIENS ;iens string for FM data array
- N PRCFDA ;FM data array
- ;
- S PRC410R=+$G(PRC410R)
- S PRCRSLT=0
- S PRCERR="Invalid input parameter"
- ;
- I PRC410R>0 D
- . K PRCERR
- . S PRCIENS=PRC410R_","
- . S PRCFDA(410,PRCIENS,39)="@" ;delete
- . S PRCFDA(410,PRCIENS,69)="@" ;delete
- . D FILE^DIE("K","PRCFDA","PRCERR")
- . ;quit if filing error
- . I $D(PRCERR) S PRCERR=$G(PRCERR("DIERR","1","TEXT",1)) Q
- . ;
- . ;success
- . S PRCRSLT=1
- ;
- Q PRCRSLT
- ;
- ;
- ITDES(PRC410R,PRCITIEN) ;Check single line item for a description
- ;This function checks a single line item on a 2237 to make sure it has a description.
- ;
- ; Input:
- ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
- ; PRCITIEN - (required) IEN of record in ITEM (#410.02) sub-file
- ;
- ; Output:
- ; Function value - 1 on success, 0 on failure (no line item description)
- ;
- N PRCIENS ;iens string for GET1^DIQ
- N PRCDESC ;word processing field target array
- N PRCRSLT ;function result
- ;
- ;
- S PRC410R=+$G(PRC410R)
- S PRCITIEN=+$G(PRCITIEN)
- S PRCRSLT=1
- ;
- ;failure if 2237 record not found in #410 file
- I (PRC410R'>0)!('$D(^PRCS(410,PRC410R))) S PRCRSLT=0
- ;
- ;failure if record not found in ITEM (#410.02) sub-file
- I (PRCITIEN'>0)!('$D(^PRCS(410,PRC410R,"IT",PRCITIEN,0))) S PRCRSLT=0
- ;
- I PRCRSLT D ;drop out of DO block on failure
- . ;
- . ;attempt to retrieve the contents of word processing Item
- . ;Description field and store text in the target array
- . K PRCDESC
- . S PRCIENS=PRCITIEN_","_PRC410R_","
- . S PRCDESC=$$GET1^DIQ(410.02,PRCIENS,1,"Z","PRCDESC")
- . ;if no data exists, quit and function result=failure
- . I PRCDESC="" S PRCRSLT=0 Q
- . ;
- . ;strip WP nodes of spaces and tabs; if node still contains data then ok
- . N PRCWP,PRCNODE,PRCOK
- . S (PRCWP,PRCOK)=0
- . F S PRCWP=$O(PRCDESC(PRCWP)) Q:'PRCWP!(PRCOK) D
- . . S PRCNODE=$G(PRCDESC(PRCWP,0))
- . . S PRCNODE=$TR(PRCNODE," ","") ;strip spaces
- . . S PRCNODE=$TR(PRCNODE,$C(9),"") ;strip tabs
- . . ;ok, data in the WP node
- . . I $L(PRCNODE)>0 S PRCOK=1
- . I 'PRCOK S PRCRSLT=0
- ;
- Q PRCRSLT
- ;
- ;
- ITDESALL(PRC410R,PRCERR) ;Check all line items for description
- ;This function checks all line items on a document to make sure they have a description.
- ;
- ; Input:
- ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
- ;
- ; Output:
- ; Function value - 1 on success, 0 on failure (one or more line items don't have description)
- ; PRCERR - (optional) on failure, an error message array is returned, pass by ref
- ; Array format:
- ; PRCERR(1)="Line Item #3 Description is missing."
- ; PRCERR(2)="Line Item #5 Description is missing."
- ; PRCERR(3), etc.
- ;
- N PRCLINE ;line items
- N PRCITIEN ;line item IEN
- N PRCLNUM ;Line Item Number
- N PRCIDX ;error array subscript
- N PRCRSLT ;function result
- ;
- S PRC410R=+$G(PRC410R)
- S PRCRSLT=1
- ;
- ;quit if 2237 record not found in #410 file
- I (PRC410R'>0)!('$D(^PRCS(410,PRC410R))) D Q PRCRSLT
- . S PRCRSLT=0
- . S PRCERR(1)="Control Point Activity record not found."
- ;
- S (PRCLINE,PRCITIEN,PRCIDX)=0
- ;loop thru "B" index of ITEM multiple
- F S PRCLINE=+$O(^PRCS(410,PRC410R,"IT","B",PRCLINE)) Q:'PRCLINE D
- . ;
- . ;get IEN of record in ITEM (#410.02) sub-file
- . S PRCITIEN=0
- . S PRCITIEN=+$O(^PRCS(410,PRC410R,"IT","B",$G(PRCLINE),PRCITIEN))
- . I 'PRCITIEN D Q
- . . S PRCRSLT=0
- . . S PRCIDX=PRCIDX+1
- . . S PRCERR(PRCIDX)="Item not found in Control Point Activity record."
- . ;
- . ;does line item have a description?
- . I '$$ITDES(PRC410R,$G(PRCITIEN)) D
- . . S PRCRSLT=0
- . . S PRCLNUM=""
- . . S PRCLNUM=$P($G(^PRCS(410,PRC410R,"IT",$G(PRCITIEN),0)),U,1)
- . . S PRCIDX=PRCIDX+1
- . . S PRCERR(PRCIDX)="Line Item #"_$G(PRCLNUM)_" Description is missing."
- ;
- Q PRCRSLT
- ;
- ;
- REQCHECK(PRC410R,PRCWARN,PRCQUIET) ;2237 required field checks
- ;This function is used to check a document and determine if the following fields
- ;are populated:
- ; - Requesting Service
- ; - Description field for all line items
- ;
- ; Input:
- ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
- ; PRCQUIET - (optional) 0=silent call, 1=output warning msgs
- ;
- ; Output:
- ; Function value - 1 on success, 0 on failure-field(s) not populated
- ; PRCWARN - (optional) on failure, an warning msg array is returned, pass by ref
- ; Array format:
- ; PRCWARN(1)="Requesting Service is missing."
- ; PRCWARN(2)="Line Item #3 Description is missing."
- ; PRCWARN(3), etc.
- ;
- N PRCRSLT ;function result
- N PRCERR ;error msg array returned by $$ITDESALL^PRCHJUTL
- N PRCI ;error msg array index
- N PRCIDX ;warning msg array index
- ;
- S PRC410R=+$G(PRC410R)
- S PRCIDX=0
- S PRCRSLT=1
- ;
- ;check for Requesting Service
- I $$GET1^DIQ(410,PRC410R,6.3)']"" D
- . S PRCRSLT=0
- . S PRCIDX=PRCIDX+1
- . S PRCWARN(PRCIDX)="Requesting Service is missing."
- ;
- ;check all line items for missing description
- I '$$ITDESALL^PRCHJUTL(PRC410R,.PRCERR) D
- . S PRCRSLT=0
- . S PRCI=0
- . F S PRCI=$O(PRCERR(PRCI)) Q:'PRCI D
- . . S PRCIDX=PRCIDX+1
- . . S PRCWARN(PRCIDX)=$G(PRCERR(PRCI))
- ;
- ;on failure and not silent, output warning
- I 'PRCRSLT,$G(PRCQUIET) D
- . W !!,"WARNING - Transaction "_$$GET1^DIQ(410,PRC410R,.01)_" is missing required data!",*7
- . S PRCIDX=0
- . F S PRCIDX=$O(PRCWARN(PRCIDX)) Q:'PRCIDX D
- . . W !?2,">>> "_$G(PRCWARN(PRCIDX))
- . W !,"The request needs to be edited prior to approval.",!
- ;
- Q PRCRSLT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHJUTL 7946 printed Feb 18, 2025@23:34:44 Page 2
- PRCHJUTL ;OI&T/LKG,KCL-UTILITY FUNCTIONS IFCAP/ECMS INTERFACE ;5/10/13 15:46
- +1 ;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23
- +2 ;Per VHA Directive 2004-38, this routine should not be modified.
- +3 ;
- +4 ;
- ECMS2237(PRCHJDA) ;Checks 2237 to see if processed in eCMS - Returns 1 if
- +1 ;processed in eCMS and 0 if not. Check on basis of whether the ECMS
- +2 ;ACTIONUID field is populated.
- +3 NEW X
- SET X=($PIECE($GET(^PRCS(410,PRCHJDA,1)),U,8)'="")
- +4 QUIT X
- +5 ;
- UPD443(PRC443R,PRCERR) ;Update file #443 record
- +1 ;This function is used to update the following fields in
- +2 ;a REQUEST WORKSHEET (#443) record:
- +3 ;
- +4 ; Field Name Field #
- +5 ; ------------------- -------
- +6 ; CURRENT STATUS 1.5
- +7 ; ACCOUNTABLE OFFICER 2
- +8 ; VALIDATION CODE 3
- +9 ; ESIG DATE/TIME 4
- +10 ;
- +11 ; Input:
- +12 ; PRC443R - (required) IEN of record in REQUEST WORKSHEET (#443) file
- +13 ;
- +14 ; Output:
- +15 ; Function Value - returns 1 on success, 0 on failure
- +16 ; PRCERR - (optional) on failure, an error message is returned,
- +17 ; pass by ref
- +18 ;
- +19 ;function result
- NEW PRCRSLT
- +20 ;iens string for FM data array
- NEW PRCIENS
- +21 ;FM data array
- NEW PRCFDA
- +22 ;
- +23 SET PRC443R=+$GET(PRC443R)
- +24 SET PRCRSLT=0
- +25 SET PRCERR="Invalid input parameter"
- +26 ;
- +27 IF PRC443R>0
- Begin DoDot:1
- +28 KILL PRCERR
- +29 SET PRCIENS=PRC443R_","
- +30 ;Pending Accountable Officer Sig.
- SET PRCFDA(443,PRCIENS,1.5)=60
- +31 ;delete
- SET PRCFDA(443,PRCIENS,2)="@"
- +32 ;delete
- SET PRCFDA(443,PRCIENS,3)="@"
- +33 ;delete
- SET PRCFDA(443,PRCIENS,4)="@"
- +34 DO FILE^DIE("K","PRCFDA","PRCERR")
- +35 ;quit if filing error
- +36 IF $DATA(PRCERR)
- SET PRCERR=$GET(PRCERR("DIERR","1","TEXT",1))
- QUIT
- +37 ;
- +38 ;success
- +39 SET PRCRSLT=1
- End DoDot:1
- +40 ;
- +41 QUIT PRCRSLT
- +42 ;
- +43 ;
- UPD410(PRC410R,PRCERR) ;Update file #410 record
- +1 ;This function is used to update the following fields in
- +2 ;a CONTROL POINT ACTIVITY (#410) record:
- +3 ;
- +4 ; Field Name Field #
- +5 ; ------------------- -------
- +6 ; ACCOUNTABLE OFFICER 39
- +7 ; AO SIGNATURE DATE 69
- +8 ;
- +9 ; Input:
- +10 ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
- +11 ;
- +12 ; Output:
- +13 ; Function Value - returns 1 on success, 0 on failure
- +14 ; PRCERR - (optional) on failure, an error message is returned,
- +15 ; pass by ref
- +16 ;
- +17 ;function result
- NEW PRCRSLT
- +18 ;iens string for FM data array
- NEW PRCIENS
- +19 ;FM data array
- NEW PRCFDA
- +20 ;
- +21 SET PRC410R=+$GET(PRC410R)
- +22 SET PRCRSLT=0
- +23 SET PRCERR="Invalid input parameter"
- +24 ;
- +25 IF PRC410R>0
- Begin DoDot:1
- +26 KILL PRCERR
- +27 SET PRCIENS=PRC410R_","
- +28 ;delete
- SET PRCFDA(410,PRCIENS,39)="@"
- +29 ;delete
- SET PRCFDA(410,PRCIENS,69)="@"
- +30 DO FILE^DIE("K","PRCFDA","PRCERR")
- +31 ;quit if filing error
- +32 IF $DATA(PRCERR)
- SET PRCERR=$GET(PRCERR("DIERR","1","TEXT",1))
- QUIT
- +33 ;
- +34 ;success
- +35 SET PRCRSLT=1
- End DoDot:1
- +36 ;
- +37 QUIT PRCRSLT
- +38 ;
- +39 ;
- ITDES(PRC410R,PRCITIEN) ;Check single line item for a description
- +1 ;This function checks a single line item on a 2237 to make sure it has a description.
- +2 ;
- +3 ; Input:
- +4 ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
- +5 ; PRCITIEN - (required) IEN of record in ITEM (#410.02) sub-file
- +6 ;
- +7 ; Output:
- +8 ; Function value - 1 on success, 0 on failure (no line item description)
- +9 ;
- +10 ;iens string for GET1^DIQ
- NEW PRCIENS
- +11 ;word processing field target array
- NEW PRCDESC
- +12 ;function result
- NEW PRCRSLT
- +13 ;
- +14 ;
- +15 SET PRC410R=+$GET(PRC410R)
- +16 SET PRCITIEN=+$GET(PRCITIEN)
- +17 SET PRCRSLT=1
- +18 ;
- +19 ;failure if 2237 record not found in #410 file
- +20 IF (PRC410R'>0)!('$DATA(^PRCS(410,PRC410R)))
- SET PRCRSLT=0
- +21 ;
- +22 ;failure if record not found in ITEM (#410.02) sub-file
- +23 IF (PRCITIEN'>0)!('$DATA(^PRCS(410,PRC410R,"IT",PRCITIEN,0)))
- SET PRCRSLT=0
- +24 ;
- +25 ;drop out of DO block on failure
- IF PRCRSLT
- Begin DoDot:1
- +26 ;
- +27 ;attempt to retrieve the contents of word processing Item
- +28 ;Description field and store text in the target array
- +29 KILL PRCDESC
- +30 SET PRCIENS=PRCITIEN_","_PRC410R_","
- +31 SET PRCDESC=$$GET1^DIQ(410.02,PRCIENS,1,"Z","PRCDESC")
- +32 ;if no data exists, quit and function result=failure
- +33 IF PRCDESC=""
- SET PRCRSLT=0
- QUIT
- +34 ;
- +35 ;strip WP nodes of spaces and tabs; if node still contains data then ok
- +36 NEW PRCWP,PRCNODE,PRCOK
- +37 SET (PRCWP,PRCOK)=0
- +38 FOR
- SET PRCWP=$ORDER(PRCDESC(PRCWP))
- if 'PRCWP!(PRCOK)
- QUIT
- Begin DoDot:2
- +39 SET PRCNODE=$GET(PRCDESC(PRCWP,0))
- +40 ;strip spaces
- SET PRCNODE=$TRANSLATE(PRCNODE," ","")
- +41 ;strip tabs
- SET PRCNODE=$TRANSLATE(PRCNODE,$CHAR(9),"")
- +42 ;ok, data in the WP node
- +43 IF $LENGTH(PRCNODE)>0
- SET PRCOK=1
- End DoDot:2
- +44 IF 'PRCOK
- SET PRCRSLT=0
- End DoDot:1
- +45 ;
- +46 QUIT PRCRSLT
- +47 ;
- +48 ;
- ITDESALL(PRC410R,PRCERR) ;Check all line items for description
- +1 ;This function checks all line items on a document to make sure they have a description.
- +2 ;
- +3 ; Input:
- +4 ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
- +5 ;
- +6 ; Output:
- +7 ; Function value - 1 on success, 0 on failure (one or more line items don't have description)
- +8 ; PRCERR - (optional) on failure, an error message array is returned, pass by ref
- +9 ; Array format:
- +10 ; PRCERR(1)="Line Item #3 Description is missing."
- +11 ; PRCERR(2)="Line Item #5 Description is missing."
- +12 ; PRCERR(3), etc.
- +13 ;
- +14 ;line items
- NEW PRCLINE
- +15 ;line item IEN
- NEW PRCITIEN
- +16 ;Line Item Number
- NEW PRCLNUM
- +17 ;error array subscript
- NEW PRCIDX
- +18 ;function result
- NEW PRCRSLT
- +19 ;
- +20 SET PRC410R=+$GET(PRC410R)
- +21 SET PRCRSLT=1
- +22 ;
- +23 ;quit if 2237 record not found in #410 file
- +24 IF (PRC410R'>0)!('$DATA(^PRCS(410,PRC410R)))
- Begin DoDot:1
- +25 SET PRCRSLT=0
- +26 SET PRCERR(1)="Control Point Activity record not found."
- End DoDot:1
- QUIT PRCRSLT
- +27 ;
- +28 SET (PRCLINE,PRCITIEN,PRCIDX)=0
- +29 ;loop thru "B" index of ITEM multiple
- +30 FOR
- SET PRCLINE=+$ORDER(^PRCS(410,PRC410R,"IT","B",PRCLINE))
- if 'PRCLINE
- QUIT
- Begin DoDot:1
- +31 ;
- +32 ;get IEN of record in ITEM (#410.02) sub-file
- +33 SET PRCITIEN=0
- +34 SET PRCITIEN=+$ORDER(^PRCS(410,PRC410R,"IT","B",$GET(PRCLINE),PRCITIEN))
- +35 IF 'PRCITIEN
- Begin DoDot:2
- +36 SET PRCRSLT=0
- +37 SET PRCIDX=PRCIDX+1
- +38 SET PRCERR(PRCIDX)="Item not found in Control Point Activity record."
- End DoDot:2
- QUIT
- +39 ;
- +40 ;does line item have a description?
- +41 IF '$$ITDES(PRC410R,$GET(PRCITIEN))
- Begin DoDot:2
- +42 SET PRCRSLT=0
- +43 SET PRCLNUM=""
- +44 SET PRCLNUM=$PIECE($GET(^PRCS(410,PRC410R,"IT",$GET(PRCITIEN),0)),U,1)
- +45 SET PRCIDX=PRCIDX+1
- +46 SET PRCERR(PRCIDX)="Line Item #"_$GET(PRCLNUM)_" Description is missing."
- End DoDot:2
- End DoDot:1
- +47 ;
- +48 QUIT PRCRSLT
- +49 ;
- +50 ;
- REQCHECK(PRC410R,PRCWARN,PRCQUIET) ;2237 required field checks
- +1 ;This function is used to check a document and determine if the following fields
- +2 ;are populated:
- +3 ; - Requesting Service
- +4 ; - Description field for all line items
- +5 ;
- +6 ; Input:
- +7 ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file
- +8 ; PRCQUIET - (optional) 0=silent call, 1=output warning msgs
- +9 ;
- +10 ; Output:
- +11 ; Function value - 1 on success, 0 on failure-field(s) not populated
- +12 ; PRCWARN - (optional) on failure, an warning msg array is returned, pass by ref
- +13 ; Array format:
- +14 ; PRCWARN(1)="Requesting Service is missing."
- +15 ; PRCWARN(2)="Line Item #3 Description is missing."
- +16 ; PRCWARN(3), etc.
- +17 ;
- +18 ;function result
- NEW PRCRSLT
- +19 ;error msg array returned by $$ITDESALL^PRCHJUTL
- NEW PRCERR
- +20 ;error msg array index
- NEW PRCI
- +21 ;warning msg array index
- NEW PRCIDX
- +22 ;
- +23 SET PRC410R=+$GET(PRC410R)
- +24 SET PRCIDX=0
- +25 SET PRCRSLT=1
- +26 ;
- +27 ;check for Requesting Service
- +28 IF $$GET1^DIQ(410,PRC410R,6.3)']""
- Begin DoDot:1
- +29 SET PRCRSLT=0
- +30 SET PRCIDX=PRCIDX+1
- +31 SET PRCWARN(PRCIDX)="Requesting Service is missing."
- End DoDot:1
- +32 ;
- +33 ;check all line items for missing description
- +34 IF '$$ITDESALL^PRCHJUTL(PRC410R,.PRCERR)
- Begin DoDot:1
- +35 SET PRCRSLT=0
- +36 SET PRCI=0
- +37 FOR
- SET PRCI=$ORDER(PRCERR(PRCI))
- if 'PRCI
- QUIT
- Begin DoDot:2
- +38 SET PRCIDX=PRCIDX+1
- +39 SET PRCWARN(PRCIDX)=$GET(PRCERR(PRCI))
- End DoDot:2
- End DoDot:1
- +40 ;
- +41 ;on failure and not silent, output warning
- +42 IF 'PRCRSLT
- IF $GET(PRCQUIET)
- Begin DoDot:1
- +43 WRITE !!,"WARNING - Transaction "_$$GET1^DIQ(410,PRC410R,.01)_" is missing required data!",*7
- +44 SET PRCIDX=0
- +45 FOR
- SET PRCIDX=$ORDER(PRCWARN(PRCIDX))
- if 'PRCIDX
- QUIT
- Begin DoDot:2
- +46 WRITE !?2,">>> "_$GET(PRCWARN(PRCIDX))
- End DoDot:2
- +47 WRITE !,"The request needs to be edited prior to approval.",!
- End DoDot:1
- +48 ;
- +49 QUIT PRCRSLT