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 Dec 13, 2024@02:08:21 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
