IBTRR ;ALB/ARH - CLAIMS TRACKING - ROI SPECIAL CONSENT SCREEN ; 08-JAN-2013
;;2.0;INTEGRATED BILLING;**458**;21-MAR-94;Build 4
;;Per VHA Directive 2004-038, this routine should not be modified.
;
EN ; -- main entry point for IBT ROI SPECIAL CONSENT
D EN^VALM("IBT ROI SPECIAL CONSENT")
Q
;
HDR ; -- header code
S VALMHDR(1)="ROI Special Consent Entries for: "_$P($G(^DPT(+$G(DFN),0)),"^")
S VALMHDR(2)=" "
Q
;
INIT ; -- init variables and list array
K ^TMP("IBTRR",$J),^TMP("IBTRRX",$J),^TMP($J,"IBTRR")
I '$G(DFN) D PAT^IBCNSM I $D(VALMQUIT) Q
D BLD
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBTRR",$J),^TMP("IBTRRX",$J),^TMP($J,"IBTRR")
D CLEAR^VALM1,CLEAN^VALM10
Q
;
;
BLD ; build list of ROI Special Concents for a Patient by Active, Effective Date and Condition
N IBCNT,IBRFN,IBR0,IBACT,IBS1,IBS2,IBS3 K ^TMP("IBTRR",$J),^TMP("IBTRRX",$J),^TMP($J,"IBTRR")
S VALMCNT=0,IBCNT=0
;
; get patient records in reverse effective date then condition order
S IBRFN=0 F S IBRFN=$O(^IBT(356.26,"C",DFN,IBRFN)) Q:'IBRFN D
. S IBR0=$G(^IBT(356.26,IBRFN,0)) S IBACT=$$ACTIVE(IBRFN,DT) I 'IBACT S IBACT=9
. S ^TMP($J,"IBTRR",IBACT,-$P(IBR0,U,4),+$P(IBR0,U,3),IBRFN)=""
;
; set up array for list manager display
S IBS1="" F S IBS1=$O(^TMP($J,"IBTRR",IBS1)) Q:IBS1="" D
. S IBS2="" F S IBS2=$O(^TMP($J,"IBTRR",IBS1,IBS2)) Q:IBS2="" D
.. S IBS3="" F S IBS3=$O(^TMP($J,"IBTRR",IBS1,IBS2,IBS3)) Q:IBS3="" D
... S IBRFN=0 F S IBRFN=$O(^TMP($J,"IBTRR",IBS1,IBS2,IBS3,IBRFN)) Q:'IBRFN D
.... D LINE(IBRFN)
;
I '$D(^TMP($J,"IBTRR")) D SET(" ",0),SET("No ROI Special Consents for this Patient",0)
Q
;
LINE(IBRFN) ; add one ROI entry to screen list
N IBR0,IBX,IBY S IBX="" Q:'$G(IBRFN)
S IBCNT=IBCNT+1 S IBR0=$G(^IBT(356.26,IBRFN,0))
;
S IBY=IBCNT,IBX=$$SETFLD^VALM1(IBY,IBX,"NUMBER")
S IBY=$$DATE($P(IBR0,U,4)),IBX=$$SETFLD^VALM1(IBY,IBX,"EFFECTIVE")
S IBY=$$DATE($P(IBR0,U,5)),IBX=$$SETFLD^VALM1(IBY,IBX,"EXPIRE")
S IBY=$$EXPAND^IBTRE(356.26,.03,$P(IBR0,U,3)),IBX=$$SETFLD^VALM1(IBY,IBX,"CONDITION")
S IBY=$$STATUS(IBRFN,DT),IBX=$$SETFLD^VALM1(IBY,IBX,"STATUS")
S IBY=$G(^IBT(356.26,IBRFN,2)),IBX=$$SETFLD^VALM1(IBY,IBX,"COMMENTS")
D SET(IBX,IBCNT)
Q
;
SET(X,CNT) ; set list manager screen array lines
S VALMCNT=VALMCNT+1
S ^TMP("IBTRR",$J,VALMCNT,0)=X Q:'CNT
S ^TMP("IBTRR",$J,"IDX",VALMCNT,+CNT)=""
S ^TMP("IBTRRX",$J,CNT)=VALMCNT_U_IBRFN
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
;
STATUS(IBRFN,DATE) ; return entries status: active or inactive/revoked on date
N X,Y S X=""
I +$G(IBRFN) S X="INACTIVE"
I +$P($G(^IBT(356.26,+$G(IBRFN),0)),U,6) S X="REVOKED"
I +$$ACTIVE(+$G(IBRFN),$G(DATE)) S X="ACTIVE"
Q X
;
ACTIVE(IBRFN,DATE) ; return True if ROI entry is Active on date
N X,IBR0 S X=0 S DATE=$G(DATE)\1 I DATE'?7N S DATE=DT
S IBR0=$G(^IBT(356.26,+$G(IBRFN),0))
I IBR0'="",DATE'<$P(IBR0,U,4),DATE'>$P(IBR0,U,5) S X=1
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRR 3079 printed Dec 13, 2024@02:28:53 Page 2
IBTRR ;ALB/ARH - CLAIMS TRACKING - ROI SPECIAL CONSENT SCREEN ; 08-JAN-2013
+1 ;;2.0;INTEGRATED BILLING;**458**;21-MAR-94;Build 4
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN ; -- main entry point for IBT ROI SPECIAL CONSENT
+1 DO EN^VALM("IBT ROI SPECIAL CONSENT")
+2 QUIT
+3 ;
HDR ; -- header code
+1 SET VALMHDR(1)="ROI Special Consent Entries for: "_$PIECE($GET(^DPT(+$GET(DFN),0)),"^")
+2 SET VALMHDR(2)=" "
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 KILL ^TMP("IBTRR",$JOB),^TMP("IBTRRX",$JOB),^TMP($JOB,"IBTRR")
+2 IF '$GET(DFN)
DO PAT^IBCNSM
IF $DATA(VALMQUIT)
QUIT
+3 DO BLD
+4 QUIT
+5 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("IBTRR",$JOB),^TMP("IBTRRX",$JOB),^TMP($JOB,"IBTRR")
+2 DO CLEAR^VALM1
DO CLEAN^VALM10
+3 QUIT
+4 ;
+5 ;
BLD ; build list of ROI Special Concents for a Patient by Active, Effective Date and Condition
+1 NEW IBCNT,IBRFN,IBR0,IBACT,IBS1,IBS2,IBS3
KILL ^TMP("IBTRR",$JOB),^TMP("IBTRRX",$JOB),^TMP($JOB,"IBTRR")
+2 SET VALMCNT=0
SET IBCNT=0
+3 ;
+4 ; get patient records in reverse effective date then condition order
+5 SET IBRFN=0
FOR
SET IBRFN=$ORDER(^IBT(356.26,"C",DFN,IBRFN))
if 'IBRFN
QUIT
Begin DoDot:1
+6 SET IBR0=$GET(^IBT(356.26,IBRFN,0))
SET IBACT=$$ACTIVE(IBRFN,DT)
IF 'IBACT
SET IBACT=9
+7 SET ^TMP($JOB,"IBTRR",IBACT,-$PIECE(IBR0,U,4),+$PIECE(IBR0,U,3),IBRFN)=""
End DoDot:1
+8 ;
+9 ; set up array for list manager display
+10 SET IBS1=""
FOR
SET IBS1=$ORDER(^TMP($JOB,"IBTRR",IBS1))
if IBS1=""
QUIT
Begin DoDot:1
+11 SET IBS2=""
FOR
SET IBS2=$ORDER(^TMP($JOB,"IBTRR",IBS1,IBS2))
if IBS2=""
QUIT
Begin DoDot:2
+12 SET IBS3=""
FOR
SET IBS3=$ORDER(^TMP($JOB,"IBTRR",IBS1,IBS2,IBS3))
if IBS3=""
QUIT
Begin DoDot:3
+13 SET IBRFN=0
FOR
SET IBRFN=$ORDER(^TMP($JOB,"IBTRR",IBS1,IBS2,IBS3,IBRFN))
if 'IBRFN
QUIT
Begin DoDot:4
+14 DO LINE(IBRFN)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 ;
+16 IF '$DATA(^TMP($JOB,"IBTRR"))
DO SET(" ",0)
DO SET("No ROI Special Consents for this Patient",0)
+17 QUIT
+18 ;
LINE(IBRFN) ; add one ROI entry to screen list
+1 NEW IBR0,IBX,IBY
SET IBX=""
if '$GET(IBRFN)
QUIT
+2 SET IBCNT=IBCNT+1
SET IBR0=$GET(^IBT(356.26,IBRFN,0))
+3 ;
+4 SET IBY=IBCNT
SET IBX=$$SETFLD^VALM1(IBY,IBX,"NUMBER")
+5 SET IBY=$$DATE($PIECE(IBR0,U,4))
SET IBX=$$SETFLD^VALM1(IBY,IBX,"EFFECTIVE")
+6 SET IBY=$$DATE($PIECE(IBR0,U,5))
SET IBX=$$SETFLD^VALM1(IBY,IBX,"EXPIRE")
+7 SET IBY=$$EXPAND^IBTRE(356.26,.03,$PIECE(IBR0,U,3))
SET IBX=$$SETFLD^VALM1(IBY,IBX,"CONDITION")
+8 SET IBY=$$STATUS(IBRFN,DT)
SET IBX=$$SETFLD^VALM1(IBY,IBX,"STATUS")
+9 SET IBY=$GET(^IBT(356.26,IBRFN,2))
SET IBX=$$SETFLD^VALM1(IBY,IBX,"COMMENTS")
+10 DO SET(IBX,IBCNT)
+11 QUIT
+12 ;
SET(X,CNT) ; set list manager screen array lines
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("IBTRR",$JOB,VALMCNT,0)=X
if 'CNT
QUIT
+3 SET ^TMP("IBTRR",$JOB,"IDX",VALMCNT,+CNT)=""
+4 SET ^TMP("IBTRRX",$JOB,CNT)=VALMCNT_U_IBRFN
+5 QUIT
+6 ;
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 ;
STATUS(IBRFN,DATE) ; return entries status: active or inactive/revoked on date
+1 NEW X,Y
SET X=""
+2 IF +$GET(IBRFN)
SET X="INACTIVE"
+3 IF +$PIECE($GET(^IBT(356.26,+$GET(IBRFN),0)),U,6)
SET X="REVOKED"
+4 IF +$$ACTIVE(+$GET(IBRFN),$GET(DATE))
SET X="ACTIVE"
+5 QUIT X
+6 ;
ACTIVE(IBRFN,DATE) ; return True if ROI entry is Active on date
+1 NEW X,IBR0
SET X=0
SET DATE=$GET(DATE)\1
IF DATE'?7N
SET DATE=DT
+2 SET IBR0=$GET(^IBT(356.26,+$GET(IBRFN),0))
+3 IF IBR0'=""
IF DATE'<$PIECE(IBR0,U,4)
IF DATE'>$PIECE(IBR0,U,5)
SET X=1
+4 QUIT X
