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

IBCNSM31.m

Go to the documentation of this file. 
  1. IBCNSM31	;ALB/AAS - INSURANCE MANAGEMENT - OUTPUTS ; 28-MAY-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. %	G EN^IBCNSM
  1. 	;
  1. EA	; -- Edit all insurance policy data
  1. 	N IBDIF,I,J,IBXX,IBCDFN,IBTRC,VALMY
  1. 	D EN^VALM2($G(XQORNOD(0)))
  1. 	D FULL^VALM1
  1. 	I $D(VALMY) S IBXX=0 F  S IBXX=$O(VALMY(IBXX)) Q:'IBXX  D  ;W !,"Entry ",X,"Selected" D
  1. 	.S IBPPOL=$G(^TMP("IBNSMDX",$J,$O(^TMP("IBNSM",$J,"IDX",IBXX,0))))
  1. 	.Q:IBPPOL=""
  1. 	.S IBCDFN=$P($G(IBPPOL),"^",4) I 'IBCDFN W !!,"Can't identify the policy!" Q
  1. 	.; -- edit patient data
  1. 	.N IBQUIT S IBQUIT=0
  1. 	.S IBCNSEH=$P($G(^IBE(350.9,1,4)),"^",1) D PAT^IBCNSEH
  1. 	.D PATPOL^IBCNSM3(IBCDFN)
  1. 	.; -- edit policy data
  1. 	.D:'$G(IBQUIT) POL^IBCNSEH,EDPOL^IBCNSM3(IBCDFN)
  1. 	.W ! D AI^IBCNSP1 D:$G(IBTRC) AIP^IBCNSP02(IBTRC)
  1. 	.Q
  1. 	;
  1. EAQ	D BLD^IBCNSM
  1. 	S VALMBCK="R"
  1. 	Q
  1. 	;
  1. LK(IBCNS)	; -- screened look up to policy file
  1. 	;      input:   IBCNS = pointer to insurance company file (36)
  1. 	;
  1. 	N DIC,IBX
  1. 	S IBCPOL=""
  1. 	I $G(IBCNS)="" G LKQ
  1. 	;
  1. 	; -- first see if any plans for this company
  1. 	S IBX=$O(^IBA(355.3,"B",+IBCNS,0)) I 'IBX G LKQ
  1. 	;
  1. 	; -- see if only one policy
  1. 	;I '$O(^IBA(355.3,"B",+IBCNS,IBX) D  G LKQ
  1. 	;
  1. 	; -- is more than one plan to choose from, let fileman do it.
  1. 	S DIC("A")="Select GROUP INSURANCE PLAN: "
  1. 	;
  1. 	S DIC="^IBA(355.3,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U)=IBCNS,($P(^(0),U,2)=1!($P(^(0),U,10)=$G(DFN)))"
  1. 	;
  1. 	D ^DIC K DIC I +Y>0 S IBCPOL=+Y
  1. 	;
  1. LKQ	Q IBCPOL
  1. 	;
  1. FUTURE	; -- if expiration date in future give warning
  1. 	I $G(IBFUTUR) K IBFUTUR Q
  1. 	I $P(^DPT(DFN,.312,IBCDFN,0),"^",4),$P(^(0),"^",4)>DT W !!,*7,"WARNING:  The expiration date for this policy is in the future!",!,"          Normally this is a past date or left blank or a past date",! S Y="@333"
  1. 	S IBFUTUR=1
  1. 	Q
  1. 	;
  1. COVERED(DFN,IBCOVP)	; -- update covered by insurance in background
  1. 	; -- input ibcovp = the covered by insurance field prior to editing
  1. 	;                   (add/edit/delete) of the 2.312 insurance type mult.
  1. 	;
  1. 	Q:$G(DFN)<1
  1. 	N X,Y,I,IBCOV,IBNCOV,DA,DR,DIE,DIC,IBINS,IBINSD
  1. 	S (IBCOV,IBNCOV)=$P($G(^DPT(DFN,.31)),"^",11)
  1. 	D ALL^IBCNS1(DFN,"IBINS",2,DT) S IBINSD=+$G(IBINS(0))
  1. 	;
  1. 	; -- initial value ="" or Unknown
  1. 	I $G(IBCOVP)=""!($G(IBCOVP)="U") S IBNCOV=$S('$O(^DPT(DFN,.312,0)):"U",IBINSD:"Y",1:"N")
  1. 	;
  1. 	; -- initial value = YES or NO (treat the same)
  1. 	I $G(IBCOVP)="Y"!($G(IBCOVP)="N") S IBNCOV=$S('$O(^DPT(DFN,.312,0)):"N",IBINSD:"Y",1:"N")
  1. 	;
  1. 	;
  1. 	I IBCOV'=IBNCOV D
  1. 	.S DIE="^DPT(",DR=".3192////"_IBNCOV,DA=DFN D ^DIE
  1. 	.I '$D(ZTQUEUED) W !!,"COVERED BY HEALTH INSURANCE changed to '"_$S(IBNCOV="Y":"YES",IBNCOV="N":"NO",1:"UNKNOWN"),"'.",!
  1. 	.H 3
  1. 	.Q
  1. 	Q
  1. 	;
  1. 3	; -- display group name as uneditable
  1. 	;    called by die, expects da = entry in 355.3
  1. 	N X
  1. 	S X=$P($G(^IBA(355.3,DA,0)),"^",3)
  1. 	W !,"GROUP NAME: ",X,$S(X'="":"// ",1:""),"  (No Editing)"
  1. 	Q
  1. 	;
  1. 4	; -- display group number as uneditable
  1. 	;    called by die, expects da = entry in 355.3
  1. 	N X
  1. 	S X=$P($G(^IBA(355.3,DA,0)),"^",4)
  1. 	W !,"GROUP NUMBER: ",X,$S(X'="":"// ",1:""),"  (No Editing)"
  1. 	Q