IBCNSJ ;ALB/CPM - INSURANCE PLAN UTILITIES ; 30-DEC-94
;;Version 2.0 ; INTEGRATED BILLING ;**28,43**; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
DEL(IBPLAN) ; Delete an Insurance Plan
; Input: IBPLAN -- Pointer to the plan in file #355.3
;
I '$G(IBPLAN) G DELQ
N DA,DIDEL,DIK,IBX
;
; - delete all associated Benefits Used
S IBX=0 F S IBX=$O(^IBA(355.5,"B",IBPLAN,IBX)) Q:'IBX D DBU(IBX)
;
; - delete all associated Annual Benefits
S IBX=0 F S IBX=$O(^IBA(355.4,"C",IBPLAN,IBX)) Q:'IBX S DA=IBX,DIDEL=355.4,DIK="^IBA(355.4," D ^DIK
;
; - delete all associated coverage limitations
S IBX=0 F S IBX=$O(^IBA(355.32,"B",IBPLAN,IBX)) Q:'IBX S DA=IBX,DIDEL=355.32,DIK="^IBA(355.32," D ^DIK
;
; - delete the plan itself
S DA=IBPLAN,DIDEL=355.3,DIK="^IBA(355.3," D ^DIK
DELQ Q
;
DBU(DA) ; Delete Benefits Used.
N DIDEL,DIK
I $G(DA) S DIDEL=355.5,DIK="^IBA(355.5," D ^DIK
Q
;
IRACT(IBPLAN,IBF) ; Inactivate/reactivate an Insurance Plan
; Input: IBPLAN -- Pointer to the plan in file #355.3
; IBF -- 1 -> plan is to be inactivated
; 0 -> plan is to be reactivated
;
I '$G(IBPLAN)!("^0^1^"'[("^"_$G(IBF)_"^")) G IRACTQ
N DA,DIE,DR,X,Y
S DA=IBPLAN,DR=".11////"_IBF,DIE="^IBA(355.3," D ^DIE
D UPDATE^IBCNSP3(IBPLAN)
IRACTQ Q
;
COV(DFN) ; Update 'Covered by Insurance?' prompt
; Input: DFN -- Pointer to the patient in file #2
;
; This call differs from COVERED^IBCNSM31 in that field #.3192
; was not edited by the user, but an action on a plan or policy
; may require that this field be changed. Plus, there is no
; output to the screen.
;
I '$G(DFN) G COVQ
N X,Y,I,IBCOV,IBNCOV,DA,DR,DIE,DIC,IBINS,IBINSD
S (IBCOV,IBNCOV)=$P($G(^DPT(DFN,.31)),"^",11)
D ALL^IBCNS1(DFN,"IBINS",2,DT) S IBINSD=+$G(IBINS(0))
S IBNCOV=$S('$O(^DPT(DFN,.312,0)):"N",IBINSD:"Y",1:"N")
I IBCOV'=IBNCOV S DIE="^DPT(",DR=".3192////"_IBNCOV,DA=DFN D ^DIE
COVQ Q
;
COMP(GN) ; Compress Insurance Plan Name or Number
; Convert to caps and strip punctuation and leading zeroes.
; Input: GN -- Insurance plan name or number to be compressed
; Output: GN1 -- The compressed name or number
;
N GN1,X
S GN1=GN I GN1?."0" S GN1="" G COMPQ
S GN1=$TR(GN1,"abcdefghijklmnopqrstuvwxyz!"" #$%&,()*+'-./:;<=>?@[]_\{|}","ABCDEFGHIJKLMNOPQRSTUVWXYZ") ; change lower-case to upper, strip away all punctuation
F X=1:1:$L(GN1) Q:$E(GN1,X)'="0" ; strip off leading zeroes
S GN1=$E(GN1,X,$L(GN1))
I GN1?."0" S GN1=""
COMPQ Q GN1
;
ANYGP(X,EX,ALL) ; Does this insurance company offer any group plans?
; Input: X -- Pointer to the company in file #36
; EX -- Pointer to an insurance plan in file #355.3
; This optional input parameter is used to exclude
; a specific plan from being considered.
; ALL -- Set to 1 if inactive plans are to be included
; Output: 0 -- Company doesn't offer any group plans
; 1 -- Company does offer group plans
;
N I,J,Y S Y=0
I '$G(X) G ANYGPQ
S I=0 F S I=$O(^IBA(355.3,"B",X,I)) Q:'I D Q:Y
.I $G(EX),I=EX Q
.S J=$G(^IBA(355.3,I,0))
.I $P(J,"^",2) D
..I $G(ALL) S Y=1 Q
..I '$P(J,"^",11) S Y=1
ANYGPQ Q Y
;
SUBS(CO,PLAN,ANY,ARR,Z) ; How many possible plan subscriptions are there?
; Input: CO -- Pointer to the company in file #36
; PLAN -- Pointer to the plan in file #355.3
; ANY -- [Optional] Set to 1 if at least one subscriber
; is to be found
; ARR -- [Optional] If defined, all policies will be
; returned in this array as
;
; ARR(DFN,ien)="", where
;
; DFN points to the patient in file #2, and
; 'ien' points to the policy in file #2.312
;
; Z -- [Optional] Set to 1 if the call is just to
; determine that there is more than one subscriber
;
; Output: Number of (potential) plan subscriptions
;
N DFN,STOP,X,Y S (STOP,X)=0
I '$G(CO)!'$G(PLAN) G SUBSQ
S DFN=0 F S DFN=$O(^DPT("AB",CO,DFN)) Q:'DFN D Q:STOP
.S Y=0 F S Y=$O(^DPT("AB",CO,DFN,Y)) Q:'Y I $P($G(^DPT(DFN,.312,Y,0)),"^",18)=PLAN S X=X+1 S:$G(ARR)]"" @ARR@(DFN,Y)="" I $G(ANY) S STOP=1 Q
.I 'STOP,X>1,$G(Z) S STOP=1
SUBSQ Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSJ 4432 printed Dec 13, 2024@02:17:11 Page 2
IBCNSJ ;ALB/CPM - INSURANCE PLAN UTILITIES ; 30-DEC-94
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**28,43**; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
DEL(IBPLAN) ; Delete an Insurance Plan
+1 ; Input: IBPLAN -- Pointer to the plan in file #355.3
+2 ;
+3 IF '$GET(IBPLAN)
GOTO DELQ
+4 NEW DA,DIDEL,DIK,IBX
+5 ;
+6 ; - delete all associated Benefits Used
+7 SET IBX=0
FOR
SET IBX=$ORDER(^IBA(355.5,"B",IBPLAN,IBX))
if 'IBX
QUIT
DO DBU(IBX)
+8 ;
+9 ; - delete all associated Annual Benefits
+10 SET IBX=0
FOR
SET IBX=$ORDER(^IBA(355.4,"C",IBPLAN,IBX))
if 'IBX
QUIT
SET DA=IBX
SET DIDEL=355.4
SET DIK="^IBA(355.4,"
DO ^DIK
+11 ;
+12 ; - delete all associated coverage limitations
+13 SET IBX=0
FOR
SET IBX=$ORDER(^IBA(355.32,"B",IBPLAN,IBX))
if 'IBX
QUIT
SET DA=IBX
SET DIDEL=355.32
SET DIK="^IBA(355.32,"
DO ^DIK
+14 ;
+15 ; - delete the plan itself
+16 SET DA=IBPLAN
SET DIDEL=355.3
SET DIK="^IBA(355.3,"
DO ^DIK
DELQ QUIT
+1 ;
DBU(DA) ; Delete Benefits Used.
+1 NEW DIDEL,DIK
+2 IF $GET(DA)
SET DIDEL=355.5
SET DIK="^IBA(355.5,"
DO ^DIK
+3 QUIT
+4 ;
IRACT(IBPLAN,IBF) ; Inactivate/reactivate an Insurance Plan
+1 ; Input: IBPLAN -- Pointer to the plan in file #355.3
+2 ; IBF -- 1 -> plan is to be inactivated
+3 ; 0 -> plan is to be reactivated
+4 ;
+5 IF '$GET(IBPLAN)!("^0^1^"'[("^"_$GET(IBF)_"^"))
GOTO IRACTQ
+6 NEW DA,DIE,DR,X,Y
+7 SET DA=IBPLAN
SET DR=".11////"_IBF
SET DIE="^IBA(355.3,"
DO ^DIE
+8 DO UPDATE^IBCNSP3(IBPLAN)
IRACTQ QUIT
+1 ;
COV(DFN) ; Update 'Covered by Insurance?' prompt
+1 ; Input: DFN -- Pointer to the patient in file #2
+2 ;
+3 ; This call differs from COVERED^IBCNSM31 in that field #.3192
+4 ; was not edited by the user, but an action on a plan or policy
+5 ; may require that this field be changed. Plus, there is no
+6 ; output to the screen.
+7 ;
+8 IF '$GET(DFN)
GOTO COVQ
+9 NEW X,Y,I,IBCOV,IBNCOV,DA,DR,DIE,DIC,IBINS,IBINSD
+10 SET (IBCOV,IBNCOV)=$PIECE($GET(^DPT(DFN,.31)),"^",11)
+11 DO ALL^IBCNS1(DFN,"IBINS",2,DT)
SET IBINSD=+$GET(IBINS(0))
+12 SET IBNCOV=$SELECT('$ORDER(^DPT(DFN,.312,0)):"N",IBINSD:"Y",1:"N")
+13 IF IBCOV'=IBNCOV
SET DIE="^DPT("
SET DR=".3192////"_IBNCOV
SET DA=DFN
DO ^DIE
COVQ QUIT
+1 ;
COMP(GN) ; Compress Insurance Plan Name or Number
+1 ; Convert to caps and strip punctuation and leading zeroes.
+2 ; Input: GN -- Insurance plan name or number to be compressed
+3 ; Output: GN1 -- The compressed name or number
+4 ;
+5 NEW GN1,X
+6 SET GN1=GN
IF GN1?."0"
SET GN1=""
GOTO COMPQ
+7 ; change lower-case to upper, strip away all punctuation
SET GN1=$TRANSLATE(GN1,"abcdefghijklmnopqrstuvwxyz!"" #$%&,()*+'-./:;<=>?@[]_\{|}","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+8 ; strip off leading zeroes
FOR X=1:1:$LENGTH(GN1)
if $EXTRACT(GN1,X)'="0"
QUIT
+9 SET GN1=$EXTRACT(GN1,X,$LENGTH(GN1))
+10 IF GN1?."0"
SET GN1=""
COMPQ QUIT GN1
+1 ;
ANYGP(X,EX,ALL) ; Does this insurance company offer any group plans?
+1 ; Input: X -- Pointer to the company in file #36
+2 ; EX -- Pointer to an insurance plan in file #355.3
+3 ; This optional input parameter is used to exclude
+4 ; a specific plan from being considered.
+5 ; ALL -- Set to 1 if inactive plans are to be included
+6 ; Output: 0 -- Company doesn't offer any group plans
+7 ; 1 -- Company does offer group plans
+8 ;
+9 NEW I,J,Y
SET Y=0
+10 IF '$GET(X)
GOTO ANYGPQ
+11 SET I=0
FOR
SET I=$ORDER(^IBA(355.3,"B",X,I))
if 'I
QUIT
Begin DoDot:1
+12 IF $GET(EX)
IF I=EX
QUIT
+13 SET J=$GET(^IBA(355.3,I,0))
+14 IF $PIECE(J,"^",2)
Begin DoDot:2
+15 IF $GET(ALL)
SET Y=1
QUIT
+16 IF '$PIECE(J,"^",11)
SET Y=1
End DoDot:2
End DoDot:1
if Y
QUIT
ANYGPQ QUIT Y
+1 ;
SUBS(CO,PLAN,ANY,ARR,Z) ; How many possible plan subscriptions are there?
+1 ; Input: CO -- Pointer to the company in file #36
+2 ; PLAN -- Pointer to the plan in file #355.3
+3 ; ANY -- [Optional] Set to 1 if at least one subscriber
+4 ; is to be found
+5 ; ARR -- [Optional] If defined, all policies will be
+6 ; returned in this array as
+7 ;
+8 ; ARR(DFN,ien)="", where
+9 ;
+10 ; DFN points to the patient in file #2, and
+11 ; 'ien' points to the policy in file #2.312
+12 ;
+13 ; Z -- [Optional] Set to 1 if the call is just to
+14 ; determine that there is more than one subscriber
+15 ;
+16 ; Output: Number of (potential) plan subscriptions
+17 ;
+18 NEW DFN,STOP,X,Y
SET (STOP,X)=0
+19 IF '$GET(CO)!'$GET(PLAN)
GOTO SUBSQ
+20 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("AB",CO,DFN))
if 'DFN
QUIT
Begin DoDot:1
+21 SET Y=0
FOR
SET Y=$ORDER(^DPT("AB",CO,DFN,Y))
if 'Y
QUIT
IF $PIECE($GET(^DPT(DFN,.312,Y,0)),"^",18)=PLAN
SET X=X+1
if $GET(ARR)]""
SET @ARR@(DFN,Y)=""
IF $GET(ANY)
SET STOP=1
QUIT
+22 IF 'STOP
IF X>1
IF $GET(Z)
SET STOP=1
End DoDot:1
if STOP
QUIT
SUBSQ QUIT X
