IBJU1 ;ALB/ARH - JBI UTILITIES ; 2/14/95
;;Version 2.0 ; INTEGRATED BILLING ;**39**; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
DATE(X) ; return date in external format
N Y S Y="" I $G(X)?7N.E S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
Q Y
;
CMPFLD(FILE,FLD,REC) ; return value of computed field
N D0,IBX,X,Y S X="",D0=REC,IBX=$P($G(^DD(+FILE,+FLD,0)),U,5,999) I IBX'="" X IBX
Q X
;
EXSET(X,D0,D1) ; returns external form of data, given file and field
N Y,C S Y=X,C=$P(^DD(+D0,+D1,0),"^",2) D Y^DIQ K C
Q Y
;
;
FASTEXIT ; -- IBJ EXIT ACTION: sets flag signaling system should be exited
S VALMBCK="Q"
D FULL^VALM1
K DIR S DIR(0)="Y",DIR("A")="Exit option entirely",DIR("B")="NO" D ^DIR
I $D(DIRUT)!(Y) S IBFASTXT=5
K DIR,DIRUT
Q
;
BM(LONG,SHORT) ; called as part of MENU PROTOCOLS HEADER code so display is set up with/without actions listed
; turn on/off display of actions, extends/contracts bottom margin and number of lines of data display
N BM S BM=$S(VALMMENU:SHORT,1:LONG)
I VALM("BM")'=BM S VALMBCK="R",VALM("BM")=BM,VALM("LINES")=(VALM("BM")-VALM("TM"))+1
Q
;
PRTCL(X) ; resets menu protocol to one passed in
N DIC,Y I $G(X)'="" S DIC=101,DIC(0)="N" D ^DIC I +Y S VALM("PROTOCOL")=+Y_";ORD(101,"
Q
;
FSTRNG(STR,WD,ARRAY) ; returns ARRAY(X) with STR parsed into lines of length WD
N X,IBI,IBCNT,DIWL,DIWR,DIWF K ARRAY,^UTILITY($J,"W") S IBCNT=0
S X=$G(STR) I X'="" S DIWL=1,DIWR=WD,DIWF="" D ^DIWP
I $D(^UTILITY($J,"W")) S (IBI,IBCNT)=0 F S IBI=$O(^UTILITY($J,"W",1,IBI)) Q:'IBI D
. S IBCNT=IBCNT+1,ARRAY(IBCNT)=$G(^UTILITY($J,"W",1,IBI,0))
K ^UTILITY($J,"W") S ARRAY=IBCNT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJU1 1698 printed Apr 09, 2024@21:04:53 Page 2
IBJU1 ;ALB/ARH - JBI UTILITIES ; 2/14/95
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**39**; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
DATE(X) ; return date in external format
+1 NEW Y
SET Y=""
IF $GET(X)?7N.E
SET Y=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+2 QUIT Y
+3 ;
CMPFLD(FILE,FLD,REC) ; return value of computed field
+1 NEW D0,IBX,X,Y
SET X=""
SET D0=REC
SET IBX=$PIECE($GET(^DD(+FILE,+FLD,0)),U,5,999)
IF IBX'=""
XECUTE IBX
+2 QUIT X
+3 ;
EXSET(X,D0,D1) ; returns external form of data, given file and field
+1 NEW Y,C
SET Y=X
SET C=$PIECE(^DD(+D0,+D1,0),"^",2)
DO Y^DIQ
KILL C
+2 QUIT Y
+3 ;
+4 ;
FASTEXIT ; -- IBJ EXIT ACTION: sets flag signaling system should be exited
+1 SET VALMBCK="Q"
+2 DO FULL^VALM1
+3 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Exit option entirely"
SET DIR("B")="NO"
DO ^DIR
+4 IF $DATA(DIRUT)!(Y)
SET IBFASTXT=5
+5 KILL DIR,DIRUT
+6 QUIT
+7 ;
BM(LONG,SHORT) ; called as part of MENU PROTOCOLS HEADER code so display is set up with/without actions listed
+1 ; turn on/off display of actions, extends/contracts bottom margin and number of lines of data display
+2 NEW BM
SET BM=$SELECT(VALMMENU:SHORT,1:LONG)
+3 IF VALM("BM")'=BM
SET VALMBCK="R"
SET VALM("BM")=BM
SET VALM("LINES")=(VALM("BM")-VALM("TM"))+1
+4 QUIT
+5 ;
PRTCL(X) ; resets menu protocol to one passed in
+1 NEW DIC,Y
IF $GET(X)'=""
SET DIC=101
SET DIC(0)="N"
DO ^DIC
IF +Y
SET VALM("PROTOCOL")=+Y_";ORD(101,"
+2 QUIT
+3 ;
FSTRNG(STR,WD,ARRAY) ; returns ARRAY(X) with STR parsed into lines of length WD
+1 NEW X,IBI,IBCNT,DIWL,DIWR,DIWF
KILL ARRAY,^UTILITY($JOB,"W")
SET IBCNT=0
+2 SET X=$GET(STR)
IF X'=""
SET DIWL=1
SET DIWR=WD
SET DIWF=""
DO ^DIWP
+3 IF $DATA(^UTILITY($JOB,"W"))
SET (IBI,IBCNT)=0
FOR
SET IBI=$ORDER(^UTILITY($JOB,"W",1,IBI))
if 'IBI
QUIT
Begin DoDot:1
+4 SET IBCNT=IBCNT+1
SET ARRAY(IBCNT)=$GET(^UTILITY($JOB,"W",1,IBI,0))
End DoDot:1
+5 KILL ^UTILITY($JOB,"W")
SET ARRAY=IBCNT
+6 QUIT
