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

IBCNSC3.m

Go to the documentation of this file. 
  1. IBCNSC3	;ALB/NLR - INACTIVATE AND REPOINT INS STUFF1 ; 20-APR-93
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. 	;
  1. RPTASK	; -- ask if user wishes to repoint patients to active insurance company
  1. 	;
  1. 	N IBR
  1. 	S DIR(0)="YO",DIR("A")="DO YOU WISH TO REPOINT "_$S(IBC=1:"THIS PATIENT",1:"THESE PATIENTS")_" TO ANOTHER INSURANCE COMPANY",DIR("B")="No"
  1. 	W !
  1. 	D ^DIR K DIR G:'Y!$D(DIRUT) R3Q
  1. 	W !
  1. 	S DIC="^DIC(36,",DIC(0)="QEAZ",DIC("A")="REPOINT "_$S(IBC=1:"THIS PATIENT",1:"THESE PATIENTS")_" TO WHICH (ACTIVE) INSURANCE COMPANY: ",DIC("S")="I +$P(^(0),U,5)=0" D ^DIC K DIC G:$D(DIRUT) R3Q
  1. 	Q:+Y<1
  1. 	S IBR=+Y D SAVE
  1. 	;
  1. REPOINT	; -- get parameters for call to DIE
  1. 	;
  1. 	S DFN=0 F  S DFN=$O(^DPT("AB",IBCNS,DFN)) Q:'DFN!('IBR)  D RPT1
  1. 	Q
  1. RPT1	;
  1. 	S IBD=0 F  S IBD=$O(^DPT("AB",IBCNS,DFN,IBD)) Q:'IBD  D CALLDIE D RPT2
  1. 	Q
  1. RPT2	;
  1. 	S IBN=0 F  S IBN=$O(^IBA(355.3,"B",IBCNS,IBN)) Q:'IBN  S DA=IBN D CALLDIE1
  1. 	;
  1. R3Q	Q
  1. 	;
  1. VERIFY	; -- allow user to change mind about inactivating company
  1. 	;
  1. 	W !
  1. 	S DIR("B")="No",DIR(0)="YO",DIR("A")="ARE YOU REALLY SURE YOU WISH TO INACTIVATE "_IBN
  1. 	S DIR("?",1)="You are about to change "_IBN_" to inactive."
  1. 	S DIR("?",2)="This means you will no longer be able to bill "
  1. 	S DIR("?")=""_IBN_" for its patients' charges."
  1. 	D ^DIR K DIR I $D(DIRUT) S IBQUIT=1
  1. 	S:Y IBV=1
  1. 	Q
  1. 	;
  1. HDR	; -- print header
  1. 	;
  1. 	W:$E(IOST,1,2)["C-"!($G(IBPAG)) @IOF
  1. 	S IBPAG=$G(IBPAG)+1
  1. 	W !,?1,"PATIENTS WITH "_$S(+IBV=0:"ACTIVE",+IBV=1:"INACTIVATED")_" INSURANCE, "_$P(^DIC(36,IBCNS,0),U),?69,"PAGE ",IBPAG,?77,$$DAT1^IBOUTL(DT)
  1. 	W !?1,"PATIENT",?31,"PATIENT ID",?52,"EFF DATE",?63,"EXP DATE",?74,"SUBSCR ID",?95,"WHOSE INS",?106,"EMPLOYER",!
  1. 	W $TR($J(" ",IOM)," ","-")
  1. 	Q
  1. 	;
  1. BUILD	; -- set list of patients in ^tmp array
  1. 	;
  1. 	K ^TMP($J,"IBCNSC2")
  1. 	S DFN=0
  1. 	F  S DFN=$O(^DPT("AB",IBCNS,DFN)),X=$$PT^IBEFUNC(DFN),IBNA=$P(X,U,1),IBNO=$P(X,U,2) S:IBNA="" IBNA="<Pt. "_DFN_" Name Missing>" Q:'DFN  S IBD=0 F  S IBD=$O(^DPT("AB",IBCNS,DFN,IBD)) Q:'IBD  D
  1. 	.S IBIND=$G(^DPT(DFN,.312,IBD,0))
  1. 	.;S IBIND2=$G(^DPT(DFN,.312,IBD,2))
  1. 	.I IBCNS'=$P(+IBIND,U) Q  ;bad x-ref,maybe later take action
  1. 	.D SET
  1. 	Q
  1. 	;
  1. CALLDIE	; -- get name of active insurance co., repoint patients to same 
  1. 	;
  1. 	;S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBD,DR=".01////"_$G(IBR) D ^DIE K DIE
  1. 	S DIE="^DPT(DFN,.312,",DA(1)=DFN,DA=IBD,DR=".01///`"_$G(IBR) D ^DIE K DIE
  1. 	Q
  1. CALLDIE1	; -- stuff .01 field of 355.3 with newly-assigned ins. co.
  1. 	;
  1. 	;S DIE="^IBA(355.3,",DA=IBN,DR=".01////"_$G(IBR) D ^DIE K DIE
  1. 	S DIE="^IBA(355.3,",DA=IBN,DR=".01///`"_$G(IBR) D ^DIE K DIE
  1. 	Q
  1. 	;
  1. SET	; -- store data to be printed in temp array
  1. 	;
  1. 	; ^tmp($j,"ibcnsc2",patient name,dfn,ien of policy) =
  1. 	;    patient id^effective date^expiration date^subscriber id^whose insurance^employer
  1. 	;
  1. 	S IBWI=$P(IBIND,"^",6)
  1. 	S VAOA("A")=$S(IBWI="v":5,IBWI="s":6,1:5)
  1. 	D OAD^VADPT
  1. 	S EMPLOYER=VAOA(9)
  1. 	S ^TMP($J,"IBCNSC2",IBNA,DFN,IBD)=IBNO_"^"_$P(IBIND,"^",8)_U_$P(IBIND,"^",4)_"^"_$P(IBIND,"^",2)_"^"_IBWI_"^"_EMPLOYER
  1. 	Q
  1. 	;
  1. SAVE	; -- save off field repointed too
  1. 	N DA,DR,DIC,DIE
  1. 	Q:'$G(IBR)
  1. 	S DA=IBCNS,DR=".16////"_IBR,DIE="^DIC(36," D ^DIE
  1. 	Q