- IBCNSM31 ;ALB/AAS/JNM - INSURANCE MANAGEMENT - OUTPUTS ;28-MAY-93
- ;;2.0;INTEGRATED BILLING;**6,28,68,413,497,516,549**;21-MAR-94;Build 54
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- % G EN^IBCNSM
- ;
- EA ; -- Edit all insurance policy data
- N IBDIF,I,J,IBXX,IBCDFN,IBTRC,VALMY
- D EN^VALM2($G(XQORNOD(0)))
- D FULL^VALM1
- ;
- ;IB*2.0*549 - Added Security Key check
- I '$D(^XUSEC("IB GROUP PLAN EDIT",DUZ)) D Q
- . W !!,*7,"Sorry, but you do not have the required privileges to Edit All"
- . K DIR
- . D PAUSE^VALM1
- . D EAQ
- ;
- I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D ;W !,"Entry ",X,"Selected" D
- .S IBPPOL=$G(^TMP("IBNSMDX",$J,$O(^TMP("IBNSM",$J,"IDX",IBXX,0))))
- .Q:IBPPOL=""
- .S IBCDFN=$P($G(IBPPOL),"^",4) I 'IBCDFN W !!,"Can't identify the policy!" Q
- .; -- edit patient data
- .N IBQUIT S IBQUIT=0
- .S IBCNSEH=$P($G(^IBE(350.9,1,4)),"^",1) D PAT^IBCNSEH
- .D BEFORE^IBCNSEVT
- .D PATPOL^IBCNSM32(IBCDFN)
- .D AFTER^IBCNSEVT,^IBCNSEVT
- .; -- edit policy data
- .D:'$G(IBQUIT) POL^IBCNSEH,EDPOL^IBCNSM3(IBCDFN)
- .W ! D AI^IBCNSP1 D:$G(IBTRC) AIP^IBCNSP02(IBTRC)
- .Q
- ;
- EAQ D BLD^IBCNSM
- S VALMBCK="R"
- Q
- ;
- LK(IBCNS) ; -- screened look up to policy file
- ; input: IBCNS = pointer to insurance company file (36)
- ;
- N DIC,IBX,DIR,DUOUT,DTOUT,DIROUT,DIRUT,X,Y,IBCPOL
- S IBCPOL=""
- I $G(IBCNS)="" G LKQ
- ;
- I '$$ANYGP^IBCNSJ(IBCNS) W !!,"This company does not offer any active group plans." G LKQ
- ;
- S DIR(0)="Y",DIR("A")="This company offers active group plans. Do you wish to select one"
- S DIR("?")="The look-up facility to select an active group plan has been enhanced to use the List Manager. Enter 'YES' if you wish to select a plan from this look-up, or 'NO' to add your own plan."
- D ^DIR K DIR I 'Y G LKQ
- ;
- S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you wish to directly enter this plan"
- S DIR("?")="The look-up facility to select an active group plan has been enhanced to use the List Manager. Enter 'NO' if you wish to select a plan from this look-up, or 'YES' to directly enter the plan."
- D ^DIR K DIR I $D(DIRUT) G LKQ
- ;
- I 'Y D LKP^IBCNSU2(IBCNS,0,0,.IBCPOL,$G(IBALR)) G LKQ
- ;
- ; MRD;IB*2.0*516 - Display new Group Name and Number fields.
- S DIC("A")="Select an Active GROUP PLAN: "
- S DIC="^IBA(355.3,",DIC(0)="AEQM",DIC("S")="I +^(0)=IBCNS,$P(^(0),U,2),'$P(^(0),U,11),$G(IBALR)'=+Y"
- ;S DIC("W")="N IBX S IBX=$G(^(0)) W "" Name: "",$E($S($P(IBX,U,3)]"""":$P(IBX,U,3),1:""<none>"")_$J("""",20),1,20),"" Number: "",$S($P(IBX,U,4)]"""":$P(IBX,U,4),1:""<none>"")"
- S DIC("W")="N IBX S IBX=$G(^(2)) W "" Name: "",$E($S($P(IBX,U,1)]"""":$P(IBX,U,1),1:""<none>"")_$J("""",20),1,20),"" Number: "",$E($S($P(IBX,U,2)]"""":$P(IBX,U,2),1:""<none>""),1,14)"
- D ^DIC K DIC I +Y>0 S IBCPOL=+Y
- ;
- ; -- see if only one policy
- ;I '$O(^IBA(355.3,"B",+IBCNS,IBX) D G LKQ
- ;
- ; -- is more than one plan to choose from, let fileman do it.
- ;S DIC("A")="Select GROUP INSURANCE PLAN: "
- ;
- ;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)))"
- ;
- ;D ^DIC K DIC I +Y>0 S IBCPOL=+Y
- ;
- LKQ Q IBCPOL
- ;
- FUTURE ; -- if expiration date in future give warning
- I $G(IBFUTUR) K IBFUTUR Q
- 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"
- S IBFUTUR=1
- Q
- ;
- COVERED(DFN,IBCOVP) ; -- update covered by insurance in background
- ; -- input ibcovp = the covered by insurance field prior to editing
- ; (add/edit/delete) of the 2.312 insurance type mult.
- ;
- Q:$G(DFN)<1
- 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))
- ;
- ; -- initial value ="" or Unknown
- I $G(IBCOVP)=""!($G(IBCOVP)="U") S IBNCOV=$S('$O(^DPT(DFN,.312,0)):"U",IBINSD:"Y",1:"N")
- ;
- ; -- initial value = YES or NO (treat the same)
- I $G(IBCOVP)="Y"!($G(IBCOVP)="N") S IBNCOV=$S('$O(^DPT(DFN,.312,0)):"N",IBINSD:"Y",1:"N")
- ;
- ;
- I IBCOV'=IBNCOV D
- .S DIE="^DPT(",DR=".3192////"_IBNCOV,DA=DFN D ^DIE
- .I '$D(ZTQUEUED)&($G(IBSUPRES)'>0) W !!,"COVERED BY HEALTH INSURANCE changed to '"_$S(IBNCOV="Y":"YES",IBNCOV="N":"NO",1:"UNKNOWN"),"'.",! H 3
- .Q
- Q
- ;
- 3 ; -- display group name as uneditable
- ; called by die, expects da = entry in 355.3
- N X
- S X=$P($G(^IBA(355.3,DA,2)),"^",1) ; IB*2.0*497 (vd)
- W !,"GROUP NAME: ",X,$S(X'="":"// ",1:"")," (No Editing)"
- Q
- ;
- 4 ; -- display group number as uneditable
- ; called by die, expects da = entry in 355.3
- N X
- S X=$P($G(^IBA(355.3,DA,2)),"^",2) ; IB*2.0*497 (vd)
- W !,"GROUP NUMBER: ",X,$S(X'="":"// ",1:"")," (No Editing)"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSM31 4849 printed Feb 18, 2025@23:43:52 Page 2
- IBCNSM31 ;ALB/AAS/JNM - INSURANCE MANAGEMENT - OUTPUTS ;28-MAY-93
- +1 ;;2.0;INTEGRATED BILLING;**6,28,68,413,497,516,549**;21-MAR-94;Build 54
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- % GOTO EN^IBCNSM
- +1 ;
- EA ; -- Edit all insurance policy data
- +1 NEW IBDIF,I,J,IBXX,IBCDFN,IBTRC,VALMY
- +2 DO EN^VALM2($GET(XQORNOD(0)))
- +3 DO FULL^VALM1
- +4 ;
- +5 ;IB*2.0*549 - Added Security Key check
- +6 IF '$DATA(^XUSEC("IB GROUP PLAN EDIT",DUZ))
- Begin DoDot:1
- +7 WRITE !!,*7,"Sorry, but you do not have the required privileges to Edit All"
- +8 KILL DIR
- +9 DO PAUSE^VALM1
- +10 DO EAQ
- End DoDot:1
- QUIT
- +11 ;
- +12 ;W !,"Entry ",X,"Selected" D
- IF $DATA(VALMY)
- SET IBXX=0
- FOR
- SET IBXX=$ORDER(VALMY(IBXX))
- if 'IBXX
- QUIT
- Begin DoDot:1
- +13 SET IBPPOL=$GET(^TMP("IBNSMDX",$JOB,$ORDER(^TMP("IBNSM",$JOB,"IDX",IBXX,0))))
- +14 if IBPPOL=""
- QUIT
- +15 SET IBCDFN=$PIECE($GET(IBPPOL),"^",4)
- IF 'IBCDFN
- WRITE !!,"Can't identify the policy!"
- QUIT
- +16 ; -- edit patient data
- +17 NEW IBQUIT
- SET IBQUIT=0
- +18 SET IBCNSEH=$PIECE($GET(^IBE(350.9,1,4)),"^",1)
- DO PAT^IBCNSEH
- +19 DO BEFORE^IBCNSEVT
- +20 DO PATPOL^IBCNSM32(IBCDFN)
- +21 DO AFTER^IBCNSEVT
- DO ^IBCNSEVT
- +22 ; -- edit policy data
- +23 if '$GET(IBQUIT)
- DO POL^IBCNSEH
- DO EDPOL^IBCNSM3(IBCDFN)
- +24 WRITE !
- DO AI^IBCNSP1
- if $GET(IBTRC)
- DO AIP^IBCNSP02(IBTRC)
- +25 QUIT
- End DoDot:1
- +26 ;
- EAQ DO BLD^IBCNSM
- +1 SET VALMBCK="R"
- +2 QUIT
- +3 ;
- LK(IBCNS) ; -- screened look up to policy file
- +1 ; input: IBCNS = pointer to insurance company file (36)
- +2 ;
- +3 NEW DIC,IBX,DIR,DUOUT,DTOUT,DIROUT,DIRUT,X,Y,IBCPOL
- +4 SET IBCPOL=""
- +5 IF $GET(IBCNS)=""
- GOTO LKQ
- +6 ;
- +7 IF '$$ANYGP^IBCNSJ(IBCNS)
- WRITE !!,"This company does not offer any active group plans."
- GOTO LKQ
- +8 ;
- +9 SET DIR(0)="Y"
- SET DIR("A")="This company offers active group plans. Do you wish to select one"
- +10 SET DIR("?")="The look-up facility to select an active group plan has been enhanced to use the List Manager. Enter 'YES' if you wish to select a plan from this look-up, or 'NO' to add your own plan."
- +11 DO ^DIR
- KILL DIR
- IF 'Y
- GOTO LKQ
- +12 ;
- +13 SET DIR(0)="Y"
- SET DIR("B")="YES"
- SET DIR("A")="Do you wish to directly enter this plan"
- +14 SET DIR("?")="The look-up facility to select an active group plan has been enhanced to use the List Manager. Enter 'NO' if you wish to select a plan from this look-up, or 'YES' to directly enter the plan."
- +15 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- GOTO LKQ
- +16 ;
- +17 IF 'Y
- DO LKP^IBCNSU2(IBCNS,0,0,.IBCPOL,$GET(IBALR))
- GOTO LKQ
- +18 ;
- +19 ; MRD;IB*2.0*516 - Display new Group Name and Number fields.
- +20 SET DIC("A")="Select an Active GROUP PLAN: "
- +21 SET DIC="^IBA(355.3,"
- SET DIC(0)="AEQM"
- SET DIC("S")="I +^(0)=IBCNS,$P(^(0),U,2),'$P(^(0),U,11),$G(IBALR)'=+Y"
- +22 ;S DIC("W")="N IBX S IBX=$G(^(0)) W "" Name: "",$E($S($P(IBX,U,3)]"""":$P(IBX,U,3),1:""<none>"")_$J("""",20),1,20),"" Number: "",$S($P(IBX,U,4)]"""":$P(IBX,U,4),1:""<none>"")"
- +23 SET DIC("W")="N IBX S IBX=$G(^(2)) W "" Name: "",$E($S($P(IBX,U,1)]"""":$P(IBX,U,1),1:""<none>"")_$J("""",20),1,20),"" Number: "",$E($S($P(IBX,U,2)]"""":$P(IBX,U,2),1:""<none>""),1,14)"
- +24 DO ^DIC
- KILL DIC
- IF +Y>0
- SET IBCPOL=+Y
- +25 ;
- +26 ; -- see if only one policy
- +27 ;I '$O(^IBA(355.3,"B",+IBCNS,IBX) D G LKQ
- +28 ;
- +29 ; -- is more than one plan to choose from, let fileman do it.
- +30 ;S DIC("A")="Select GROUP INSURANCE PLAN: "
- +31 ;
- +32 ;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)))"
- +33 ;
- +34 ;D ^DIC K DIC I +Y>0 S IBCPOL=+Y
- +35 ;
- LKQ QUIT IBCPOL
- +1 ;
- FUTURE ; -- if expiration date in future give warning
- +1 IF $GET(IBFUTUR)
- KILL IBFUTUR
- QUIT
- +2 IF $PIECE(^DPT(DFN,.312,IBCDFN,0),"^",4)
- IF $PIECE(^(0),"^",4)>DT
- WRITE !!,*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",!
- SET Y="@333"
- +3 SET IBFUTUR=1
- +4 QUIT
- +5 ;
- COVERED(DFN,IBCOVP) ; -- update covered by insurance in background
- +1 ; -- input ibcovp = the covered by insurance field prior to editing
- +2 ; (add/edit/delete) of the 2.312 insurance type mult.
- +3 ;
- +4 if $GET(DFN)<1
- QUIT
- +5 NEW X,Y,I,IBCOV,IBNCOV,DA,DR,DIE,DIC,IBINS,IBINSD
- +6 SET (IBCOV,IBNCOV)=$PIECE($GET(^DPT(DFN,.31)),"^",11)
- +7 DO ALL^IBCNS1(DFN,"IBINS",2,DT)
- SET IBINSD=+$GET(IBINS(0))
- +8 ;
- +9 ; -- initial value ="" or Unknown
- +10 IF $GET(IBCOVP)=""!($GET(IBCOVP)="U")
- SET IBNCOV=$SELECT('$ORDER(^DPT(DFN,.312,0)):"U",IBINSD:"Y",1:"N")
- +11 ;
- +12 ; -- initial value = YES or NO (treat the same)
- +13 IF $GET(IBCOVP)="Y"!($GET(IBCOVP)="N")
- SET IBNCOV=$SELECT('$ORDER(^DPT(DFN,.312,0)):"N",IBINSD:"Y",1:"N")
- +14 ;
- +15 ;
- +16 IF IBCOV'=IBNCOV
- Begin DoDot:1
- +17 SET DIE="^DPT("
- SET DR=".3192////"_IBNCOV
- SET DA=DFN
- DO ^DIE
- +18 IF '$DATA(ZTQUEUED)&($GET(IBSUPRES)'>0)
- WRITE !!,"COVERED BY HEALTH INSURANCE changed to '"_$SELECT(IBNCOV="Y":"YES",IBNCOV="N":"NO",1:"UNKNOWN"),"'.",!
- HANG 3
- +19 QUIT
- End DoDot:1
- +20 QUIT
- +21 ;
- 3 ; -- display group name as uneditable
- +1 ; called by die, expects da = entry in 355.3
- +2 NEW X
- +3 ; IB*2.0*497 (vd)
- SET X=$PIECE($GET(^IBA(355.3,DA,2)),"^",1)
- +4 WRITE !,"GROUP NAME: ",X,$SELECT(X'="":"// ",1:"")," (No Editing)"
- +5 QUIT
- +6 ;
- 4 ; -- display group number as uneditable
- +1 ; called by die, expects da = entry in 355.3
- +2 NEW X
- +3 ; IB*2.0*497 (vd)
- SET X=$PIECE($GET(^IBA(355.3,DA,2)),"^",2)
- +4 WRITE !,"GROUP NUMBER: ",X,$SELECT(X'="":"// ",1:"")," (No Editing)"
- +5 QUIT