- 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 Jan 18, 2025@03:25:31 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