- IBCNSUR3 ;WOIFO/AAT - MOVE SUBSCRIBERS (BULLETIN) ;09-SEP-96
- ;;2.0;INTEGRATED BILLING;**276,549**;21-MAR-94;Build 54
- ;;Per VA Directive 6402, this routine should not be modified.
- Q
- ;
- ;add line to the bulletin
- ADD(IBTAB,IBX1,IBX2,IBX3,IBX4,IBX5) ;
- N IBX
- S IBLN=IBLN+1
- S IBX="" S:$G(IBTAB)>1 $E(IBX,IBTAB-1)=" "
- S @REF@(IBLN)=IBX_$G(IBX1)_$G(IBX2)_$G(IBX3)_$G(IBX4)_$G(IBX5)
- Q
- ;
- BHEAD ; Bulletin header
- D ADD(1,"MOVE SUBSCRIBERS OF ONE PLAN TO ANOTHER PLAN")
- D ADD()
- D ADD(1,"You selected to move ",$S(+$G(IBGRP):IBSUB,1:+NUMSEL)," subscriber(s)")
- D ADD()
- D ADD(5,"FROM Insurance Company ",IBC1N)
- D ADD(10,"Plan Name ",$P(IBP1N,U,1)," Number ",IBP1X)
- D ADD(5,"TO Insurance Company ",IBC2N)
- D ADD(10,"Plan Name ",IBP2N," Number ",IBP2X)
- I IBSPLIT D
- . D ADD(5,"BY switching to the new Insurance/Plan")
- . D ADD(10,"with Effective Date ",$$DAT1^IBOUTL(IBEFFDT))
- D ADD()
- D ADD(1,"The old group plan and policy was ",$S(IBSPLIT:"set EXPIRED",1:"REPLACED")," in the patient profile."),ADD()
- D ADD(1,"Patient Name/ID Whose Employer Effective Expires")
- D ADD(1,"-------------------------------------------------------------------------------")
- Q
- ; Add subscriber to the bulletin
- ADS(DFN,IBCDFN) ;
- N IBX,IBZ,IB2
- S IBZ=$G(^DPT(DFN,.312,IBCDFN,0))
- S IB2=$G(^DPT(DFN,.312,IBCDFN,2))
- S IBX=$E($P($G(^DPT(DFN,0)),U),1,22),$E(IBX,22)=" "
- S IBX=$E(IBX_$E($P($G(^DPT(DFN,0)),U,9),6,10),1,28),$E(IBX,28)=" "
- S IBX=$E(IBX_$$EXTERNAL^DILFD(2.312,6,,$P(IBZ,U,6)),1,36),$E(IBX,37)=" "
- S IBX=$E(IBX_$P(IB2,U,9),1,59),$E(IBX,59)=" "
- S IBX=$E(IBX_$$DAT1^IBOUTL($P(IBZ,U,8)),1,71),$E(IBX,71)=" "
- S IBX=$E(IBX_$$DAT1^IBOUTL($P(IBZ,U,4)),1,80)
- D ADD(1,IBX)
- Q
- ;
- DONE ;
- N IBGRP,XMDUZ,XMTEXT,XMSUB,XMY,%
- ;
- D NOW^%DTC
- D ADD()
- D ADD(1,"THE PROCESS COMPLETED SUCCESSFULLY ON "_$$DAT1^IBOUTL(%,1))
- ;
- S XMSUB="SUBSCRIPTION LIST FOR INACTIVATED PLAN"
- S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="^TMP("_$J_",""IBCNSUR1"","
- S XMY(DUZ)=""
- S XMY("G.IB NEW INSURANCE")=""
- D ^XMD
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSUR3 2084 printed Jan 18, 2025@03:19:19 Page 2
- IBCNSUR3 ;WOIFO/AAT - MOVE SUBSCRIBERS (BULLETIN) ;09-SEP-96
- +1 ;;2.0;INTEGRATED BILLING;**276,549**;21-MAR-94;Build 54
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;add line to the bulletin
- ADD(IBTAB,IBX1,IBX2,IBX3,IBX4,IBX5) ;
- +1 NEW IBX
- +2 SET IBLN=IBLN+1
- +3 SET IBX=""
- if $GET(IBTAB)>1
- SET $EXTRACT(IBX,IBTAB-1)=" "
- +4 SET @REF@(IBLN)=IBX_$GET(IBX1)_$GET(IBX2)_$GET(IBX3)_$GET(IBX4)_$GET(IBX5)
- +5 QUIT
- +6 ;
- BHEAD ; Bulletin header
- +1 DO ADD(1,"MOVE SUBSCRIBERS OF ONE PLAN TO ANOTHER PLAN")
- +2 DO ADD()
- +3 DO ADD(1,"You selected to move ",$SELECT(+$GET(IBGRP):IBSUB,1:+NUMSEL)," subscriber(s)")
- +4 DO ADD()
- +5 DO ADD(5,"FROM Insurance Company ",IBC1N)
- +6 DO ADD(10,"Plan Name ",$PIECE(IBP1N,U,1)," Number ",IBP1X)
- +7 DO ADD(5,"TO Insurance Company ",IBC2N)
- +8 DO ADD(10,"Plan Name ",IBP2N," Number ",IBP2X)
- +9 IF IBSPLIT
- Begin DoDot:1
- +10 DO ADD(5,"BY switching to the new Insurance/Plan")
- +11 DO ADD(10,"with Effective Date ",$$DAT1^IBOUTL(IBEFFDT))
- End DoDot:1
- +12 DO ADD()
- +13 DO ADD(1,"The old group plan and policy was ",$SELECT(IBSPLIT:"set EXPIRED",1:"REPLACED")," in the patient profile.")
- DO ADD()
- +14 DO ADD(1,"Patient Name/ID Whose Employer Effective Expires")
- +15 DO ADD(1,"-------------------------------------------------------------------------------")
- +16 QUIT
- +17 ; Add subscriber to the bulletin
- ADS(DFN,IBCDFN) ;
- +1 NEW IBX,IBZ,IB2
- +2 SET IBZ=$GET(^DPT(DFN,.312,IBCDFN,0))
- +3 SET IB2=$GET(^DPT(DFN,.312,IBCDFN,2))
- +4 SET IBX=$EXTRACT($PIECE($GET(^DPT(DFN,0)),U),1,22)
- SET $EXTRACT(IBX,22)=" "
- +5 SET IBX=$EXTRACT(IBX_$EXTRACT($PIECE($GET(^DPT(DFN,0)),U,9),6,10),1,28)
- SET $EXTRACT(IBX,28)=" "
- +6 SET IBX=$EXTRACT(IBX_$$EXTERNAL^DILFD(2.312,6,,$PIECE(IBZ,U,6)),1,36)
- SET $EXTRACT(IBX,37)=" "
- +7 SET IBX=$EXTRACT(IBX_$PIECE(IB2,U,9),1,59)
- SET $EXTRACT(IBX,59)=" "
- +8 SET IBX=$EXTRACT(IBX_$$DAT1^IBOUTL($PIECE(IBZ,U,8)),1,71)
- SET $EXTRACT(IBX,71)=" "
- +9 SET IBX=$EXTRACT(IBX_$$DAT1^IBOUTL($PIECE(IBZ,U,4)),1,80)
- +10 DO ADD(1,IBX)
- +11 QUIT
- +12 ;
- DONE ;
- +1 NEW IBGRP,XMDUZ,XMTEXT,XMSUB,XMY,%
- +2 ;
- +3 DO NOW^%DTC
- +4 DO ADD()
- +5 DO ADD(1,"THE PROCESS COMPLETED SUCCESSFULLY ON "_$$DAT1^IBOUTL(%,1))
- +6 ;
- +7 SET XMSUB="SUBSCRIPTION LIST FOR INACTIVATED PLAN"
- +8 SET XMDUZ="INTEGRATED BILLING PACKAGE"
- SET XMTEXT="^TMP("_$JOB_",""IBCNSUR1"","
- +9 SET XMY(DUZ)=""
- +10 SET XMY("G.IB NEW INSURANCE")=""
- +11 DO ^XMD
- +12 QUIT