- IBCNSM1 ;ALB/AAS - INSURANCE MANAGEMENT - OUTPUTS ; 05-MAY-2015
- ;;2.0;INTEGRATED BILLING;**28,56,549**; 21-MAR-94;Build 54
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- % G EN^IBCNSM
- ;
- VP ; -- View Patient Policy Info
- D FULL^VALM1
- N I,J,IBXX,VALMY
- D EN^VALM2($G(XQORNOD(0)))
- 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=""
- .D EN^VALM("IBCNS EXPANDED POLICY")
- .Q
- I '$G(IBFASTXT) D BLD^IBCNSM
- S VALMBCK="R" Q
- ;
- AB ; -- Edit Annual Benefits
- 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 Annual Benefits."
- . K DIR
- . D PAUSE^VALM1
- . S VALMBCK="R"
- ;
- N I,J,IBXX,VALMY
- D EN^VALM2($G(XQORNOD(0)))
- I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
- .S IBPPOL=$G(^TMP("IBNSMDX",$J,$O(^TMP("IBNSM",$J,"IDX",IBXX,0))))
- .Q:IBPPOL=""
- .S IBCNS=$P(IBPPOL,"^",5),IBCPOL=$P(IBPPOL,"^",22)
- .D FULL^VALM1
- .D EN^VALM("IBCNS ANNUAL BENEFITS")
- .Q
- S VALMBCK="R"
- Q
- ;
- UP ; -- Print new, not verified insurance
- ;
- N I,J,IBXX,IBCNS,VALMY
- D EN^VALM2($G(XQORNOD(0)))
- I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) W !,IBXX,! H 2 Q:'IBXX D
- .S IBPPOL=$G(^TMP("IBNSMDX",$J,$O(^TMP("IBNSM",$J,"IDX",IBXX,0))))
- .Q:IBPPOL=""
- .S IBCNS=$P(IBPPOL,"^",5),IBCPOL=$P(IBPPOL,"^",22)
- .S INSCO=^DIC(36,IBCNS,0)
- .W !!,$P(INSCO,"^"),!! H 2
- .W !!,$P(IBPPOL,"^",4),!! H 2
- .Q
- D FULL^VALM1
- W !!,"REPORT OF NEW NOT VERIFIED INSURANCE",!! H 2
- S VALMBCK="R" Q
- ;
- PC ; -- Print Patient Insurance info
- ;N IBLINE,IBCY,IBWP
- N IBWP
- ;
- PCWP ; -- Print Insurance Coverage, Worksheet
- ;
- N I,J,IBXX,IBLINE,IBCY,VALMY
- D EN^VALM2($G(XQORNOD(0)))
- I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
- .S IBPPOL=$G(^TMP("IBNSMDX",$J,$O(^TMP("IBNSM",$J,"IDX",IBXX,0))))
- .Q:IBPPOL=""
- .S IBCPOL=$P(IBPPOL,"^",22)
- .S IBLINE=$S($G(IBWP):1,1:0)
- .S IBCY=$S($G(IBWP):0,1:1)
- .D WPPC^IBCNSM5
- .Q
- S VALMBCK="R" Q
- ;
- WP ; -- Print Worksheet
- N IBWP
- S IBWP=1
- D PCWP
- S VALMBCK="R" Q
- ;
- DP ; -- Delete insurance policy
- D FULL^VALM1
- I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) D SORRY^IBTRE1 G DPQ
- N I,J,IBXX,DIR,DIRUT,IBBCNT,BLD,IBCOVP,IBFNOPOL,VALMY
- D EN^VALM2($G(XQORNOD(0)))
- S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11)
- ; if no policies, set ibfnopol flag to prevent call to pause^valm1
- ; at label dpq
- I '$D(VALMY) S IBFNOPOL=1
- I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX!$D(DIRUT) D
- .S IBPPOL=$G(^TMP("IBNSMDX",$J,$O(^TMP("IBNSM",$J,"IDX",IBXX,0))))
- .; do some error checking here
- .I $$DELP^IBCNSU(DFN,$P(IBPPOL,"^",5)) D Q
- ..W !,"You can't delete this policy, there are bills associated with it."
- ..W ! S J=0 F S J=$O(^DGCR(399,"AE",DFN,$P(IBPPOL,"^",5),J)) Q:'J I $P(^DGCR(399,J,"S"),"^",17)="" W $P(^DGCR(399,J,0),"^")_" " S IBBCNT=$G(IBBCNT)+1 W:'(IBBCNT#8) !
- ..K IBBCNT
- ..Q
- .;
- .; - warn if there are associated Insurance reviews
- .I $$IR^IBCNSJ21(DFN,+$P(IBPPOL,"^",4)) W !,*7,"Please note that there are Insurance Reviews associated with this policy!!",!
- .;
- .S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are You Sure you want to delete policy #"_IBXX
- .D ^DIR K DIR I Y'=1 W !,"Policy #",IBXX," not Deleted!" Q
- .S IBCDFN=$P(IBPPOL,"^",4)
- .D DP1
- .Q
- DPQ D COVERED^IBCNSM31(DFN,$G(IBCOVP))
- I '$G(IBFNOPOL) D PAUSE^VALM1
- I $G(BLD) D BLD^IBCNSM
- S VALMBCK="R" Q
- ;
- DP1 ; -- actual deletion
- N DA,DIC,DIK,IBJJ,IBJJJ,IBBU,IBPLAN,IBCPOLD
- S IBPLAN=$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",18),IBCPOLD=$G(^IBA(355.3,+IBPLAN,0))
- ;
- ; -- delete riders
- S IBJJ=0 F S IBJJ=$O(^IBA(355.7,"APP",DFN,IBCDFN,IBJJ)) Q:'IBJJ D
- .S IBJJJ=0 F S IBJJJ=$O(^IBA(355.7,"APP",DFN,IBCDFN,IBJJ,IBJJJ)) Q:'IBJJJ S DA=IBJJJ,DIK="^IBA(355.7,",DIDEL=355.7 D ^DIK
- ;
- ; -- delete benefits used
- I IBPLAN D BU^IBCNSJ21 S IBJJ="" F S IBJJ=$O(IBBU(IBJJ)) Q:IBJJ="" D DBU^IBCNSJ(IBBU(IBJJ))
- ;
- ; -- remove pointers from Insurance reviews
- S IBJJ=0 F S IBJJ=$O(^IBT(356.2,"D",DFN,IBJJ)) Q:'IBJJ I $P($G(^IBT(356.2,IBJJ,1)),"^",5)=IBCDFN S $P(^(1),"^",5)=""
- ;
- ; -- if individual policy, and is right patient, delete HIP
- S BLD=1
- I '$P(IBCPOLD,"^",2),DFN=$P(IBCPOLD,"^",10) D DEL^IBCNSJ(IBPLAN)
- ;
- ; -- delete entry in patient file
- S DA=IBCDFN,DA(1)=DFN,DIK="^DPT("_DFN_",.312," D ^DIK
- W:$G(IBXX) !,"Entry ",$G(IBXX)," Deleted"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSM1 4529 printed Jan 18, 2025@03:18:38 Page 2
- IBCNSM1 ;ALB/AAS - INSURANCE MANAGEMENT - OUTPUTS ; 05-MAY-2015
- +1 ;;2.0;INTEGRATED BILLING;**28,56,549**; 21-MAR-94;Build 54
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- % GOTO EN^IBCNSM
- +1 ;
- VP ; -- View Patient Policy Info
- +1 DO FULL^VALM1
- +2 NEW I,J,IBXX,VALMY
- +3 DO EN^VALM2($GET(XQORNOD(0)))
- +4 ;W !,"Entry ",X,"Selected" D
- IF $DATA(VALMY)
- SET IBXX=0
- FOR
- SET IBXX=$ORDER(VALMY(IBXX))
- if 'IBXX
- QUIT
- Begin DoDot:1
- +5 SET IBPPOL=$GET(^TMP("IBNSMDX",$JOB,$ORDER(^TMP("IBNSM",$JOB,"IDX",IBXX,0))))
- +6 if IBPPOL=""
- QUIT
- +7 DO EN^VALM("IBCNS EXPANDED POLICY")
- +8 QUIT
- End DoDot:1
- +9 IF '$GET(IBFASTXT)
- DO BLD^IBCNSM
- +10 SET VALMBCK="R"
- QUIT
- +11 ;
- AB ; -- Edit Annual Benefits
- +1 DO FULL^VALM1
- +2 ;
- +3 ; IB*2.0*549 - Added Security Key check
- +4 IF '$DATA(^XUSEC("IB GROUP PLAN EDIT",DUZ))
- Begin DoDot:1
- +5 WRITE !!,*7,"Sorry, but you do not have the required privileges to edit Annual Benefits."
- +6 KILL DIR
- +7 DO PAUSE^VALM1
- +8 SET VALMBCK="R"
- End DoDot:1
- QUIT
- +9 ;
- +10 NEW I,J,IBXX,VALMY
- +11 DO EN^VALM2($GET(XQORNOD(0)))
- +12 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 IBCNS=$PIECE(IBPPOL,"^",5)
- SET IBCPOL=$PIECE(IBPPOL,"^",22)
- +16 DO FULL^VALM1
- +17 DO EN^VALM("IBCNS ANNUAL BENEFITS")
- +18 QUIT
- End DoDot:1
- +19 SET VALMBCK="R"
- +20 QUIT
- +21 ;
- UP ; -- Print new, not verified insurance
- +1 ;
- +2 NEW I,J,IBXX,IBCNS,VALMY
- +3 DO EN^VALM2($GET(XQORNOD(0)))
- +4 IF $DATA(VALMY)
- SET IBXX=0
- FOR
- SET IBXX=$ORDER(VALMY(IBXX))
- WRITE !,IBXX,!
- HANG 2
- if 'IBXX
- QUIT
- Begin DoDot:1
- +5 SET IBPPOL=$GET(^TMP("IBNSMDX",$JOB,$ORDER(^TMP("IBNSM",$JOB,"IDX",IBXX,0))))
- +6 if IBPPOL=""
- QUIT
- +7 SET IBCNS=$PIECE(IBPPOL,"^",5)
- SET IBCPOL=$PIECE(IBPPOL,"^",22)
- +8 SET INSCO=^DIC(36,IBCNS,0)
- +9 WRITE !!,$PIECE(INSCO,"^"),!!
- HANG 2
- +10 WRITE !!,$PIECE(IBPPOL,"^",4),!!
- HANG 2
- +11 QUIT
- End DoDot:1
- +12 DO FULL^VALM1
- +13 WRITE !!,"REPORT OF NEW NOT VERIFIED INSURANCE",!!
- HANG 2
- +14 SET VALMBCK="R"
- QUIT
- +15 ;
- PC ; -- Print Patient Insurance info
- +1 ;N IBLINE,IBCY,IBWP
- +2 NEW IBWP
- +3 ;
- PCWP ; -- Print Insurance Coverage, Worksheet
- +1 ;
- +2 NEW I,J,IBXX,IBLINE,IBCY,VALMY
- +3 DO EN^VALM2($GET(XQORNOD(0)))
- +4 IF $DATA(VALMY)
- SET IBXX=0
- FOR
- SET IBXX=$ORDER(VALMY(IBXX))
- if 'IBXX
- QUIT
- Begin DoDot:1
- +5 SET IBPPOL=$GET(^TMP("IBNSMDX",$JOB,$ORDER(^TMP("IBNSM",$JOB,"IDX",IBXX,0))))
- +6 if IBPPOL=""
- QUIT
- +7 SET IBCPOL=$PIECE(IBPPOL,"^",22)
- +8 SET IBLINE=$SELECT($GET(IBWP):1,1:0)
- +9 SET IBCY=$SELECT($GET(IBWP):0,1:1)
- +10 DO WPPC^IBCNSM5
- +11 QUIT
- End DoDot:1
- +12 SET VALMBCK="R"
- QUIT
- +13 ;
- WP ; -- Print Worksheet
- +1 NEW IBWP
- +2 SET IBWP=1
- +3 DO PCWP
- +4 SET VALMBCK="R"
- QUIT
- +5 ;
- DP ; -- Delete insurance policy
- +1 DO FULL^VALM1
- +2 IF '$DATA(^XUSEC("IB INSURANCE SUPERVISOR",DUZ))
- DO SORRY^IBTRE1
- GOTO DPQ
- +3 NEW I,J,IBXX,DIR,DIRUT,IBBCNT,BLD,IBCOVP,IBFNOPOL,VALMY
- +4 DO EN^VALM2($GET(XQORNOD(0)))
- +5 SET IBCOVP=$PIECE($GET(^DPT(DFN,.31)),"^",11)
- +6 ; if no policies, set ibfnopol flag to prevent call to pause^valm1
- +7 ; at label dpq
- +8 IF '$DATA(VALMY)
- SET IBFNOPOL=1
- +9 IF $DATA(VALMY)
- SET IBXX=0
- FOR
- SET IBXX=$ORDER(VALMY(IBXX))
- if 'IBXX!$DATA(DIRUT)
- QUIT
- Begin DoDot:1
- +10 SET IBPPOL=$GET(^TMP("IBNSMDX",$JOB,$ORDER(^TMP("IBNSM",$JOB,"IDX",IBXX,0))))
- +11 ; do some error checking here
- +12 IF $$DELP^IBCNSU(DFN,$PIECE(IBPPOL,"^",5))
- Begin DoDot:2
- +13 WRITE !,"You can't delete this policy, there are bills associated with it."
- +14 WRITE !
- SET J=0
- FOR
- SET J=$ORDER(^DGCR(399,"AE",DFN,$PIECE(IBPPOL,"^",5),J))
- if 'J
- QUIT
- IF $PIECE(^DGCR(399,J,"S"),"^",17)=""
- WRITE $PIECE(^DGCR(399,J,0),"^")_" "
- SET IBBCNT=$GET(IBBCNT)+1
- if '(IBBCNT#8)
- WRITE !
- +15 KILL IBBCNT
- +16 QUIT
- End DoDot:2
- QUIT
- +17 ;
- +18 ; - warn if there are associated Insurance reviews
- +19 IF $$IR^IBCNSJ21(DFN,+$PIECE(IBPPOL,"^",4))
- WRITE !,*7,"Please note that there are Insurance Reviews associated with this policy!!",!
- +20 ;
- +21 SET DIR(0)="Y"
- SET DIR("B")="NO"
- SET DIR("A")="Are You Sure you want to delete policy #"_IBXX
- +22 DO ^DIR
- KILL DIR
- IF Y'=1
- WRITE !,"Policy #",IBXX," not Deleted!"
- QUIT
- +23 SET IBCDFN=$PIECE(IBPPOL,"^",4)
- +24 DO DP1
- +25 QUIT
- End DoDot:1
- DPQ DO COVERED^IBCNSM31(DFN,$GET(IBCOVP))
- +1 IF '$GET(IBFNOPOL)
- DO PAUSE^VALM1
- +2 IF $GET(BLD)
- DO BLD^IBCNSM
- +3 SET VALMBCK="R"
- QUIT
- +4 ;
- DP1 ; -- actual deletion
- +1 NEW DA,DIC,DIK,IBJJ,IBJJJ,IBBU,IBPLAN,IBCPOLD
- +2 SET IBPLAN=$PIECE($GET(^DPT(DFN,.312,IBCDFN,0)),"^",18)
- SET IBCPOLD=$GET(^IBA(355.3,+IBPLAN,0))
- +3 ;
- +4 ; -- delete riders
- +5 SET IBJJ=0
- FOR
- SET IBJJ=$ORDER(^IBA(355.7,"APP",DFN,IBCDFN,IBJJ))
- if 'IBJJ
- QUIT
- Begin DoDot:1
- +6 SET IBJJJ=0
- FOR
- SET IBJJJ=$ORDER(^IBA(355.7,"APP",DFN,IBCDFN,IBJJ,IBJJJ))
- if 'IBJJJ
- QUIT
- SET DA=IBJJJ
- SET DIK="^IBA(355.7,"
- SET DIDEL=355.7
- DO ^DIK
- End DoDot:1
- +7 ;
- +8 ; -- delete benefits used
- +9 IF IBPLAN
- DO BU^IBCNSJ21
- SET IBJJ=""
- FOR
- SET IBJJ=$ORDER(IBBU(IBJJ))
- if IBJJ=""
- QUIT
- DO DBU^IBCNSJ(IBBU(IBJJ))
- +10 ;
- +11 ; -- remove pointers from Insurance reviews
- +12 SET IBJJ=0
- FOR
- SET IBJJ=$ORDER(^IBT(356.2,"D",DFN,IBJJ))
- if 'IBJJ
- QUIT
- IF $PIECE($GET(^IBT(356.2,IBJJ,1)),"^",5)=IBCDFN
- SET $PIECE(^(1),"^",5)=""
- +13 ;
- +14 ; -- if individual policy, and is right patient, delete HIP
- +15 SET BLD=1
- +16 IF '$PIECE(IBCPOLD,"^",2)
- IF DFN=$PIECE(IBCPOLD,"^",10)
- DO DEL^IBCNSJ(IBPLAN)
- +17 ;
- +18 ; -- delete entry in patient file
- +19 SET DA=IBCDFN
- SET DA(1)=DFN
- SET DIK="^DPT("_DFN_",.312,"
- DO ^DIK
- +20 if $GET(IBXX)
- WRITE !,"Entry ",$GET(IBXX)," Deleted"
- +21 QUIT