- 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 Feb 18, 2025@23:43:35 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