Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBTRR1

IBTRR1.m

Go to the documentation of this file.
  1. IBTRR1 ;ALB/ARH - CLAIMS TRACKING - ROI SPECIAL CONSENT ACTIONS ; 08-JAN-2013
  1. ;;2.0;INTEGRATED BILLING;**458**;21-MAR-94;Build 4
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. AA ; Protocol Action: Add an ROI Special Consent
  1. I '$D(^XUSEC("IB ROI EDIT",DUZ)) W !!,"IB ROI EDIT Key Required to Add an ROI" H 2 S VALMBCK="R" Q
  1. D FULL^VALM1
  1. ;
  1. D ADD I +$G(IBRFN) D EDIT
  1. ;
  1. D BLD^IBTRR
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. EA ; Protocol Action: Edit an ROI Special Consent
  1. I '$D(^XUSEC("IB ROI EDIT",DUZ)) W !!,"IB ROI EDIT Key Required to Edit an ROI" H 2 S VALMBCK="R" Q
  1. D FULL^VALM1
  1. ;
  1. N VALMY,I,J,IBXXR,IBRFN
  1. D EN^VALM2($G(XQORNOD(0)))
  1. I $D(VALMY) S IBXXR=0 F S IBXXR=$O(VALMY(IBXXR)) Q:'IBXXR D
  1. . S IBRFN=$P($G(^TMP("IBTRRX",$J,+$O(^TMP("IBTRR",$J,"IDX",IBXXR,0)))),U,2)
  1. . D ROIDSP(IBRFN)
  1. . D EDIT
  1. ;
  1. D BLD^IBTRR
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. RA ; Protocol Action: Revoke an ROI Special Consent
  1. I '$D(^XUSEC("IB ROI EDIT",DUZ)) W !!,"IB ROI EDIT Key Required to Revoke an ROI" H 2 S VALMBCK="R" Q
  1. D FULL^VALM1
  1. ;
  1. N VALMY,I,J,IBXXR,IBRFN
  1. D EN^VALM2($G(XQORNOD(0)))
  1. I $D(VALMY) S IBXXR=0 F S IBXXR=$O(VALMY(IBXXR)) Q:'IBXXR D
  1. . S IBRFN=$P($G(^TMP("IBTRRX",$J,+$O(^TMP("IBTRR",$J,"IDX",IBXXR,0)))),U,2)
  1. . D ROIDSP(IBRFN)
  1. . D REVOKE
  1. ;
  1. D BLD^IBTRR
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. DA ; Protocol Action: Delete an ROI Special Consent
  1. I '$D(^XUSEC("IB ROI EDIT",DUZ)) W !!,"IB ROI EDIT Key Required to Delete an ROI" H 2 S VALMBCK="R" Q
  1. D FULL^VALM1
  1. ;
  1. N VALMY,I,J,IBXXR,IBRFN
  1. D EN^VALM2($G(XQORNOD(0)))
  1. I $D(VALMY) S IBXXR=0 F S IBXXR=$O(VALMY(IBXXR)) Q:'IBXXR D
  1. . S IBRFN=$P($G(^TMP("IBTRRX",$J,+$O(^TMP("IBTRR",$J,"IDX",IBXXR,0)))),U,2)
  1. . D ROIDSP(IBRFN)
  1. . D DELETE
  1. ;
  1. D BLD^IBTRR
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. OP ; Protocol Action: Open ROI Screen - called from CT Editor IBTRE ROI CONSENT
  1. D EN^IBTRR D HDR^IBTRE,BLD^IBTRE S VALMBCK="R"
  1. Q
  1. ;
  1. ;
  1. ADD ; add a new ROI Special Consent entry, IBRFN set on exit (record incomplete)
  1. N DD,DO,DA,DR,D0,DIR,DIC,DIE,DLAYGO,X,Y,VALMQUIT S IBRFN=0 W !
  1. ;
  1. I '$G(DFN) D PAT^IBCNSM W !! I '$D(DFN) Q
  1. ;
  1. S DIR(0)="Y",DIR("B")="NO",DIR("A")="Add a New ROI Special Consent" D ^DIR I Y'=1 Q
  1. ;
  1. W !!,"A New ROI Special Consent has been added for: ",$P($G(^DPT(+DFN,0)),U,1),!
  1. ;
  1. S X=$P(^IBT(356.26,0),U,3)+1
  1. S DIC="^IBT(356.26,",DIC(0)="L",DLAYGO=356.26
  1. S DIC("DR")=".02////"_DFN_";1.01///NOW;1.02////"_DUZ_";1.03///NOW;1.04////"_DUZ
  1. D FILE^DICN K DIC,DIE,DLAYGO I Y>0 S IBRFN=+Y
  1. ;
  1. Q
  1. ;
  1. EDIT ; edit an ROI Special Consent entry, IBRFN must be set on entry
  1. N DIC,DIE,DR,DA,D0,IBROIBG,IBDIFF,X,Y
  1. ;
  1. I '$D(^IBT(356.26,+$G(IBRFN),0)) Q
  1. D SAVE
  1. ;
  1. S DIE="^IBT(356.26,",DA=+IBRFN,DIE("NO^")="BACK"
  1. S DR=".03;@1;.04;S IBROIBG=X;.05;I X<IBROIBG W !!,""Expiraton date must not be before the Effective Date!"",! S Y=""@1"";2.01"
  1. D ^DIE
  1. ;
  1. D COMP I IBDIFF D UPDATE
  1. K ^TMP($J,"IBTRRS",356.26)
  1. Q
  1. ;
  1. REVOKE ; revoke an ROI entry, IBRFN must be defined
  1. N DIC,DIE,DR,DA,D0,IBDIFF,X,Y
  1. ;
  1. I '$D(^IBT(356.26,+$G(IBRFN),0)) Q
  1. D SAVE
  1. ;
  1. S DIE="^IBT(356.26,",DA=+IBRFN,DIE("NO^")="BACK"
  1. S DR=".06;I X'=1 S Y=""@1"";W !!,""Update the Expiration Date with the Date the revocation becomes effective."",!;.05;@1"
  1. D ^DIE
  1. ;
  1. D COMP I IBDIFF D UPDATE
  1. K ^TMP($J,"IBTRRS",356.26)
  1. Q
  1. ;
  1. DELETE ; delete and ROI entry, IBRFN must be defined
  1. N DIR,DIK,DA,DIRUT,X,Y
  1. ;
  1. I '$D(^IBT(356.26,+$G(IBRFN),0)) Q
  1. ;
  1. S DIR(0)="Y",DIR("B")="NO",DIR("A")="Delete this ROI Special Consent" D ^DIR I Y'=1 W " Not Deleted!" Q
  1. ;
  1. I Y=1 S DA=IBRFN,DIK="^IBT(356.26," D ^DIK W " Entry Deleted!"
  1. ;
  1. Q
  1. ;
  1. ;
  1. SAVE ; save entry before editing
  1. K ^TMP($J,"IBTRRS",356.26)
  1. S ^TMP($J,"IBTRRS",356.26,IBRFN,0)=$G(^IBT(356.26,+IBRFN,0))
  1. S ^TMP($J,"IBTRRS",356.26,IBRFN,1)=$G(^IBT(356.26,+IBRFN,1))
  1. S ^TMP($J,"IBTRRS",356.26,IBRFN,2)=$G(^IBT(356.26,+IBRFN,2))
  1. Q
  1. ;
  1. COMP ; compare before editing global with current global entry
  1. S IBDIFF=0
  1. I $G(^IBT(356.26,+IBRFN,0))'=$G(^TMP($J,"IBTRRS",356.26,IBRFN,0)) S IBDIFF=1
  1. I $G(^IBT(356.26,+IBRFN,1))'=$G(^TMP($J,"IBTRRS",356.26,IBRFN,1)) S IBDIFF=1
  1. I $G(^IBT(356.26,+IBRFN,2))'=$G(^TMP($J,"IBTRRS",356.26,IBRFN,2)) S IBDIFF=1
  1. Q
  1. ;
  1. UPDATE ; update last edited fields for entry
  1. N DIC,DIE,DR,DA,D0,X,Y
  1. S DIE="^IBT(356.26,",DA=+IBRFN,DR="1.03///NOW;1.04////"_DUZ D ^DIE
  1. Q
  1. ;
  1. ;
  1. ROIDSP(IBRFN) ; display an ROI entry
  1. N IBR0,IBR1,IBR2,IBDS S IBDS="",$P(IBDS,"-",IOM+1)=""
  1. S IBR0=$G(^IBT(356.26,+$G(IBRFN),0)) Q:IBR0=""
  1. S IBR1=$G(^IBT(356.26,IBRFN,1)),IBR2=$G(^IBT(356.26,IBRFN,2))
  1. ;
  1. W !!,IBDS,!,"ROI Special Consent for ",$P($G(^DPT(+$P(IBR0,U,2),0)),U,1),":"
  1. W !!,$$EXPAND^IBTRE(356.26,.03,$P(IBR0,U,3)),?37,$$DATE^IBTRR($P(IBR0,U,4))," - ",$$DATE^IBTRR($P(IBR0,U,5))
  1. W ?60,$S(+$$ACTIVE^IBTRR(IBRFN,DT):"ACTIVE",1:"INACTIVE"),?70,$S(+$P(IBR0,U,6):"REVOKED",1:"")
  1. W !!,"Comment: ",IBR2
  1. W !!,"Entered by: ",$E($$EXPAND^IBTRE(356.26,1.02,$P(IBR1,U,2)),1,21),?37,"Last Edited By: ",$E($$EXPAND^IBTRE(356.26,1.04,$P(IBR1,U,4)),1,21)
  1. W !,"Date Entered: ",$$FMTE^XLFDT($P(IBR1,U,1)),?37,"Date Last Edited: ",$$FMTE^XLFDT($P(IBR1,U,3)),!,IBDS,!
  1. Q
  1. ;
  1. ;
  1. ROIPAT(DFN,DATE) ; return Indicators of Conditions Active for Patient on Date (LM Patient List header)
  1. ; outputs alpha characters of sensitive conditions with active ROI
  1. N IBX,IBY,IBZ,IBRFN,IBR0 S (IBX,IBY,IBZ)="" S DFN=+$G(DFN) S DATE=$G(DATE)\1 I DATE'?7N S DATE=DT
  1. ;
  1. S IBRFN=0 F S IBRFN=$O(^IBT(356.26,"C",DFN,IBRFN)) Q:'IBRFN D
  1. . S IBR0=$G(^IBT(356.26,IBRFN,0))
  1. . I IBR0'="",DATE'<$P(IBR0,U,4),DATE'>$P(IBR0,U,5) S IBY(+$P(IBR0,U,3))=""
  1. S IBZ="" F IBY=1:1:4 I $D(IBY(IBY)) S IBZ=IBZ_IBY
  1. S IBX=$TR(IBZ,"1234","DAHS")
  1. Q IBX
  1. ;
  1. ROIEVT(IBTRN,SHRT) ; return ROI Consent and Indicators for a specific CT Event and Date (LM Event Detail)
  1. ; outputs CT entries ROI Consent and alpha characters of sensitive conditions with active ROI
  1. ;
  1. N IBX,IBY,IBTRN0,IBRSC S IBX="" S IBTRN0=$G(^IBT(356,+$G(IBTRN),0)),IBRSC=$P(IBTRN0,U,31)
  1. I +IBRSC S IBX=$$EXPAND^IBTRE(356,.31,IBRSC)_" "
  1. I +IBRSC=2 S IBY=$$ROIPAT(+$P(IBTRN0,U,2),+$P(IBTRN0,U,6)) I IBY'="" S:$G(SHRT) IBX=$E(IBX,1,6) S IBX=IBX_"("_IBY_")"
  1. Q IBX