- IBCRLS ;ALB/ARH - RATES: DISPLAY SCHEDULES ; 16-MAY-1996
- ;;Version 2.0 ; INTEGRATED BILLING ;**52**; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- EN ; -- main entry point for IBCR RATE SCHEDULE
- D EN^VALM("IBCR RATE SCHEDULE")
- Q
- ;
- HDR ; -- header code
- S VALMHDR(1)="Link types of payers and charges"
- S VALMSG="~ charges not auto added to bills"
- Q
- ;
- INIT ; -- init variables and list array
- K ^TMP("IBCRLS",$J),^TMP("IBCRLSX1",$J)
- D BLD
- Q
- ;
- HELP ; -- help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- EXIT ; -- exit code
- K ^TMP("IBCRLS",$J),^TMP("IBCRLSX1",$J)
- D CLEAR^VALM1,CLEAN^VALM10
- Q
- ;
- BLD ; build LM array for rate schedule display
- N IBRT,IBBT,IBCNT,IBCNT1,IBRTBT,IBRSFN,IBCGS,IBLN,IBLN1,IBX,IBY,IBRS10,X S (VALMCNT,IBCNT)=0 K ^TMP($J,"IBCRRS")
- ;
- D SORTRS
- ;
- ; create LM display array
- S IBRT="" F S IBRT=$O(^TMP($J,"IBCRRS",IBRT)) Q:IBRT="" D
- . S IBBT="" F S IBBT=$O(^TMP($J,"IBCRRS",IBRT,IBBT)) Q:IBBT="" D
- .. ;
- .. S IBRTBT=$G(^TMP($J,"IBCRRS",IBRT,IBBT))
- .. D SET("",IBRTBT) S IBY=" "_IBRT_": "_$$BTYPE(IBBT)
- .. D SET(IBY) D CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM)
- .. ;
- .. S IBRSFN=0 F S IBRSFN=$O(^TMP($J,"IBCRRS",IBRT,IBBT,IBRSFN)) Q:'IBRSFN D
- ... S IBLN=$G(^IBE(363,IBRSFN,0)) Q:IBLN=""
- ... S IBCNT=IBCNT+1,IBY=""
- ... S IBX=$P(IBLN,U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"RSCHD")
- ... S IBX=$$EMUTL^IBCRU1(+$P(IBLN,U,4),2),IBY=$$SETFLD^VALM1(IBX,IBY,"BSVS")
- ... S IBX=$$DATE(+$P(IBLN,U,5)),IBY=$$SETFLD^VALM1(IBX,IBY,"EFFDT")
- ... S IBX=$$DATE(+$P(IBLN,U,6)),IBY=$$SETFLD^VALM1(IBX,IBY,"INADT")
- ... ;
- ... S IBRS10=$G(^IBE(363,IBRSFN,10)) I IBRS10'="" D
- .... S IBY=$$SETFLD^VALM1(" Y",IBY,"ADJ") S X=100 X IBRS10
- .... S IBX="(if base $=100, adjusted $="_$J(X,0,2)_") "_IBRS10,IBY=$$SETFLD^VALM1(IBX,IBY,"ADJMC")
- ... ;
- ... S IBCGS=0,IBCNT1=IBCNT F S IBCGS=$O(^IBE(363,IBRSFN,11,IBCGS)) Q:'IBCGS D
- .... S IBLN1=$G(^IBE(363,IBRSFN,11,IBCGS,0)) Q:'IBLN1
- .... S IBX=$P(IBLN1,U,2) I 'IBX S IBX="~",IBY=$$SETFLD^VALM1(IBX,IBY,"AA")
- .... S IBX=$P($G(^IBE(363.1,+IBLN1,0)),U,1),IBY=$$SETFLD^VALM1(IBX,IBY,"CGSET")
- .... D SET(IBY) S IBCNT1=0,IBY=""
- ... I +IBCNT1 D SET(IBY)
- ;
- I VALMCNT=0 D SET(" "),SET("No Rate Schedules defined")
- ;
- K ^TMP($J,"IBCRRS")
- Q
- ;
- SET(X,RTBTLN) ; set up list manager screen array (if RTBTLN, the line is the first line of the rate tpe-bill type section)
- S VALMCNT=VALMCNT+1
- S ^TMP("IBCRLS",$J,VALMCNT,0)=X
- I +$G(RTBTLN) S ^TMP("IBCRLSX1",$J,+RTBTLN,+$P(RTBTLN,U,2))=VALMCNT
- Q
- ;
- SORTRS ; sort rate schedules by rate type name, bill type
- ; ^TMP($J,"IBCRRS", rate type, bill type)= rate type ifn ^ bill type
- ; ^TMP($J,"IBCRRS", rate type, bill type, rate schedule IFN)=""
- N IBRSFN,IBLN,IBRT,IBBT
- S IBRSFN=0 F S IBRSFN=$O(^IBE(363,IBRSFN)) Q:'IBRSFN D
- . S IBLN=$G(^IBE(363,IBRSFN,0)) Q:IBLN=""
- . S IBRT=$P($G(^DGCR(399.3,+$P(IBLN,U,2),0)),U,1),IBBT=$P(IBLN,U,3)
- . S ^TMP($J,"IBCRRS",IBRT,IBBT)=+$P(IBLN,U,2)_U_+$P(IBLN,U,3)
- . S ^TMP($J,"IBCRRS",IBRT,IBBT,IBRSFN)=""
- Q
- ;
- DATE(X) ; 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
- ;
- BTYPE(X) ; return abbreviated form of Bill Type
- Q $S($G(X)>2:"Outpatient",$G(X)>0:"Inpatient",1:"")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRLS 3291 printed Feb 18, 2025@23:46:11 Page 2
- IBCRLS ;ALB/ARH - RATES: DISPLAY SCHEDULES ; 16-MAY-1996
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;**52**; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- EN ; -- main entry point for IBCR RATE SCHEDULE
- +1 DO EN^VALM("IBCR RATE SCHEDULE")
- +2 QUIT
- +3 ;
- HDR ; -- header code
- +1 SET VALMHDR(1)="Link types of payers and charges"
- +2 SET VALMSG="~ charges not auto added to bills"
- +3 QUIT
- +4 ;
- INIT ; -- init variables and list array
- +1 KILL ^TMP("IBCRLS",$JOB),^TMP("IBCRLSX1",$JOB)
- +2 DO BLD
- +3 QUIT
- +4 ;
- HELP ; -- help code
- +1 SET X="?"
- DO DISP^XQORM1
- WRITE !!
- +2 QUIT
- +3 ;
- EXIT ; -- exit code
- +1 KILL ^TMP("IBCRLS",$JOB),^TMP("IBCRLSX1",$JOB)
- +2 DO CLEAR^VALM1
- DO CLEAN^VALM10
- +3 QUIT
- +4 ;
- BLD ; build LM array for rate schedule display
- +1 NEW IBRT,IBBT,IBCNT,IBCNT1,IBRTBT,IBRSFN,IBCGS,IBLN,IBLN1,IBX,IBY,IBRS10,X
- SET (VALMCNT,IBCNT)=0
- KILL ^TMP($JOB,"IBCRRS")
- +2 ;
- +3 DO SORTRS
- +4 ;
- +5 ; create LM display array
- +6 SET IBRT=""
- FOR
- SET IBRT=$ORDER(^TMP($JOB,"IBCRRS",IBRT))
- if IBRT=""
- QUIT
- Begin DoDot:1
- +7 SET IBBT=""
- FOR
- SET IBBT=$ORDER(^TMP($JOB,"IBCRRS",IBRT,IBBT))
- if IBBT=""
- QUIT
- Begin DoDot:2
- +8 ;
- +9 SET IBRTBT=$GET(^TMP($JOB,"IBCRRS",IBRT,IBBT))
- +10 DO SET("",IBRTBT)
- SET IBY=" "_IBRT_": "_$$BTYPE(IBBT)
- +11 DO SET(IBY)
- DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM)
- +12 ;
- +13 SET IBRSFN=0
- FOR
- SET IBRSFN=$ORDER(^TMP($JOB,"IBCRRS",IBRT,IBBT,IBRSFN))
- if 'IBRSFN
- QUIT
- Begin DoDot:3
- +14 SET IBLN=$GET(^IBE(363,IBRSFN,0))
- if IBLN=""
- QUIT
- +15 SET IBCNT=IBCNT+1
- SET IBY=""
- +16 SET IBX=$PIECE(IBLN,U,1)
- SET IBY=$$SETFLD^VALM1(IBX,IBY,"RSCHD")
- +17 SET IBX=$$EMUTL^IBCRU1(+$PIECE(IBLN,U,4),2)
- SET IBY=$$SETFLD^VALM1(IBX,IBY,"BSVS")
- +18 SET IBX=$$DATE(+$PIECE(IBLN,U,5))
- SET IBY=$$SETFLD^VALM1(IBX,IBY,"EFFDT")
- +19 SET IBX=$$DATE(+$PIECE(IBLN,U,6))
- SET IBY=$$SETFLD^VALM1(IBX,IBY,"INADT")
- +20 ;
- +21 SET IBRS10=$GET(^IBE(363,IBRSFN,10))
- IF IBRS10'=""
- Begin DoDot:4
- +22 SET IBY=$$SETFLD^VALM1(" Y",IBY,"ADJ")
- SET X=100
- XECUTE IBRS10
- +23 SET IBX="(if base $=100, adjusted $="_$JUSTIFY(X,0,2)_") "_IBRS10
- SET IBY=$$SETFLD^VALM1(IBX,IBY,"ADJMC")
- End DoDot:4
- +24 ;
- +25 SET IBCGS=0
- SET IBCNT1=IBCNT
- FOR
- SET IBCGS=$ORDER(^IBE(363,IBRSFN,11,IBCGS))
- if 'IBCGS
- QUIT
- Begin DoDot:4
- +26 SET IBLN1=$GET(^IBE(363,IBRSFN,11,IBCGS,0))
- if 'IBLN1
- QUIT
- +27 SET IBX=$PIECE(IBLN1,U,2)
- IF 'IBX
- SET IBX="~"
- SET IBY=$$SETFLD^VALM1(IBX,IBY,"AA")
- +28 SET IBX=$PIECE($GET(^IBE(363.1,+IBLN1,0)),U,1)
- SET IBY=$$SETFLD^VALM1(IBX,IBY,"CGSET")
- +29 DO SET(IBY)
- SET IBCNT1=0
- SET IBY=""
- End DoDot:4
- +30 IF +IBCNT1
- DO SET(IBY)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +31 ;
- +32 IF VALMCNT=0
- DO SET(" ")
- DO SET("No Rate Schedules defined")
- +33 ;
- +34 KILL ^TMP($JOB,"IBCRRS")
- +35 QUIT
- +36 ;
- SET(X,RTBTLN) ; set up list manager screen array (if RTBTLN, the line is the first line of the rate tpe-bill type section)
- +1 SET VALMCNT=VALMCNT+1
- +2 SET ^TMP("IBCRLS",$JOB,VALMCNT,0)=X
- +3 IF +$GET(RTBTLN)
- SET ^TMP("IBCRLSX1",$JOB,+RTBTLN,+$PIECE(RTBTLN,U,2))=VALMCNT
- +4 QUIT
- +5 ;
- SORTRS ; sort rate schedules by rate type name, bill type
- +1 ; ^TMP($J,"IBCRRS", rate type, bill type)= rate type ifn ^ bill type
- +2 ; ^TMP($J,"IBCRRS", rate type, bill type, rate schedule IFN)=""
- +3 NEW IBRSFN,IBLN,IBRT,IBBT
- +4 SET IBRSFN=0
- FOR
- SET IBRSFN=$ORDER(^IBE(363,IBRSFN))
- if 'IBRSFN
- QUIT
- Begin DoDot:1
- +5 SET IBLN=$GET(^IBE(363,IBRSFN,0))
- if IBLN=""
- QUIT
- +6 SET IBRT=$PIECE($GET(^DGCR(399.3,+$PIECE(IBLN,U,2),0)),U,1)
- SET IBBT=$PIECE(IBLN,U,3)
- +7 SET ^TMP($JOB,"IBCRRS",IBRT,IBBT)=+$PIECE(IBLN,U,2)_U_+$PIECE(IBLN,U,3)
- +8 SET ^TMP($JOB,"IBCRRS",IBRT,IBBT,IBRSFN)=""
- End DoDot:1
- +9 QUIT
- +10 ;
- DATE(X) ; 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 ;
- BTYPE(X) ; return abbreviated form of Bill Type
- +1 QUIT $SELECT($GET(X)>2:"Outpatient",$GET(X)>0:"Inpatient",1:"")
