IBCNOR4 ;AITC/DTG - IBCN DUP GROUP TO INS USAGE ;12/14/23
;;2.0;INTEGRATED BILLING;**778**;21-MAR-94;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; entry point
;
N DIR,IBAR,IBCK,IBCNT,IBI,IBID,IBOK,IBONE,IBOUT,IBSTOP,IBTYP,IBXSAV,POP,X,Y
K ^TMP("IBCNOR4",$J) S ^TMP("IBCNOR4",$J,0)=""
W:$G(IOF)'="" @IOF W:$G(IOF)="" !
W !,"This report can help identify potential duplicate group plans by group"
W !,"number in one or more insurance companies. Search through the entire"
W !,"database for duplicate groups or narrow down the search by a specific"
W !,"group number."
; get group numbers
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
ENTYP ; get type equal or contain or all
;
W ! S IBTYP=""
K DIR S DIR(0)="S^1:ALL Duplicate Groups;2:Specific Group Number"
S DIR("A")="SELECT 1 or 2"
S DIR("?",1)="All Duplicate Groups will search the entire database and if exact"
S DIR("?",2)="duplicates are found (by group number), all duplicate group results"
S DIR("?",3)="from all insurance companies will display on the report."
S DIR("?",4)=" "
S DIR("?",5)="Specific Group Number requires the user to enter a specific group"
S DIR("?",6)="number and will return all results of the searched group from all"
S DIR("?",7)="insurance companies (regardless of number of instances)."
S DIR("?")="Enter '^' to quit, OR"
D ^DIR
I Y="" S Y=1
I $E(Y)=U!$D(DIROUT)!$D(DIRUT)!$D(DTOUT)!$D(DUOUT) S Y="^"
I $E(Y)=U G EXIT
S IBTYP=+Y I 'Y G EXIT
I IBTYP=1 G CON ; if looking for all skip the group number question
;
ENRK ; come here if continue from ^ response
K ^TMP("IBCNOR4",$J) S ^TMP("IBCNOR4",$J,0)=""
ENR ; ask question return point.
W !
K DIR S DIR(0)="F^1:30"
S DIR("A")="Enter a Group Number"
S DIR("?")="Enter a specific Group/Plan Number or '^' to quit"
S IBOK=0
ENAQ ;
D ^DIR
;
I $E(Y,1)=" " S IBOK=0 D I 'IBOK S Y="" W !,"This is a required response. Enter '^' to exit" G ENAQ
. F IBI=1:1:$L(Y) I $E(Y,IBI)'=" " S IBOK=1 Q
I $E(Y)=U!$D(DIROUT)!$D(DIRUT)!$D(DTOUT)!$D(DUOUT) S Y=U
D ISET
I $E(Y)=U G EXIT
G RE
;
CON ; continue if all
I IBTYP'=1 G RE
W !!!,"WARNING: You have selected to run this report for all duplicate groups."
W !,"In doing so, this report will take a long time to run.",!
K DIR,DIRUT,DIROUT,DTOUT,DUOUT
S DIR(0)="Y"
S DIR("A")="Do you want to continue"
S DIR("B")="NO"
S DIR("?",1)=" Enter YES to continue."
S DIR("?")=" Enter NO or '^' to exit."
D ^DIR K DIR
I 'Y G EXIT ; do not wish to continue
;
RE ; report or excel
S IBSTOP=0 D OUT I IBSTOP G EXIT
;
D DEVICE
;
EXIT ; quit point
;
K ^TMP("IBCNOR4",$J)
Q
;
;
ISET ; if item save and set flag
;
N IBA,IBC,IBD,IBE,IBFND
I Y=""!($E(Y)=U) Q ; leave IBOK 0 in order to stop
S ^TMP("IBCNOR4",$J,1,Y)=1,^TMP("IBCNOR4",$J,0)=1,^TMP("IBCNOR4",$J,"U",($$UP^XLFSTR(Y)))=1
Q
;
OUT ; Prompt to allow users to select output format
; Returns: E - Output to excel
; R - Output to report
; IBSTOP=1 - No Selection made
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
W !
S DIR(0)="SA^E:Excel;R:Report"
S DIR("A")="(E)xcel Format or (R)eport Format: "
S DIR("B")="Report"
S DIR("?",1)="Select 'E' to create CSV output for import into Excel."
S DIR("?")="Select 'R' to create a standard report."
D ^DIR K DIR
I $D(DIROUT)!$D(DIRUT)!$D(DTOUT)!$D(DUOUT) S IBSTOP=1 G OUTQ
S IBOUT=Y
Q
OUTQ ;
;
Q
;
DEVICE ;
N IBB,POP,ZTDESC,ZTRTN,ZTSAVE
I IBOUT="R" W !!,"***This report is 132 characters wide.***",!
I IBOUT="E" D
. W !!,"For CSV output, turn logging or capture on now.",!
. W "To avoid undesired wrapping of the data, please"
. W !," enter '0;256;99999'.",!
K IBXSAV M IBXSAV=^TMP("IBCNOR4",$J)
S ZTRTN="COMPILE^IBCNOR4"
S ZTDESC="LD - LIST DUPLICATE GROUP PLANS BY INS CO"
F IBB="IBOUT","IBTYP","IBXSAV(" S ZTSAVE(IBB)=""
D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,"Q") ; ICR # 1519
;
Q
;
;
COMPILE ; build output of payers
;
N %,IB3553,IB36,IBA,IBADDR,IBARY,IBB,IBC,IBCTL,IBCHK,IBCNT,IBCRT,IBDASHES,IBDOT,IBEORMSG,IBFILTER
N IBGCT,IBGNAM,IBGON,IBHDR
N IBHDRDATE,IBHDRNAME,IBINDX,IBINS,IBITM,IBL,IBLOOK,IBLNC,IBLS,IBMAXCNT,IBNM,IBNONEMSG
N IBPGC,IBS,IBS3553,IBSPACES,IBST,IBSTAB,IBSTOP,IBSI,IBSTOP,IBUN,IBW,IBXTFEED,IBZIP
;
S IBOUT=$G(IBOUT)
S IBCHK=0
S IBMAXCNT=IOSL-3,IBXTFEED=21,IBCRT=1,IBLNC=0
I IOST'["C-" S IBMAXCNT=IOSL-6,IBXTFEED=50,IBCRT=0
S IBEORMSG="*** End of Report ***"
S IBNONEMSG="* * * N o D a t a F o u n d * * *"
S IBHDRNAME="List Duplicate Group Plans by Insurance Company"
D NOW^%DTC
S IBHDRDATE=$$DAT2^IBOUTL($E(%,1,12))
S $P(IBDASHES,"-",132)=""
S $P(IBSPACES," ",80)=""
S IBHDR="HDR"_$S(IBOUT="E":"E",1:"R")
K ^TMP($J,"IBCNOR4")
K ^TMP($J,"IBCNOR4-1")
K IBFND
M ^TMP($J,"IBCNOR4")=IBXSAV
S IBDOT=2000 I IBTYP=1 S IBDOT=100000 ; reduce dots for subscribers when all are selected
;
;compile
; walk the indexes
;
I IBCRT W !,"Checking for Duplicate Group Number(s)",!
S IBFILTER="" I IBTYP=2 S IBFILTER="Selected: "
D RUN
; if all collect all group numbers
I IBTYP=1 S IBFILTER="All Group Numbers"
I IBTYP=2 S IBLOOK="",IBCNT=0 F S IBLOOK=$O(^TMP($J,"IBCNOR4",1,IBLOOK)) Q:IBLOOK="" D
. S IBB=$G(^TMP($J,"IBCNOR4",1,IBLOOK)) I IBB=1 S IBFILTER=IBFILTER_($S('+IBCHK:"",1:", "))_IBLOOK S IBCHK=IBCHK+1
;
D WALK ; get subscriber counts
;
; uses ^TMP($J,"IBCNOR4-1") to print
;
PRINT ; out put the compile in insurance co name order
;
N IBA,IBGLIN
K IBW,IBARY
S IBSTOP=0,IBPGC=0,IBGCT=0,IBGON=""
I '+$G(^TMP($J,"IBCNOR4-1",2)) D NOD G EXITC
D:IBOUT="E" HDRE D:IBOUT="R" HDRR
I IBOUT="E" D
. S IBNM="" F S IBNM=$O(^TMP($J,"IBCNOR4-1",6,IBNM)) Q:IBNM="" D
.. S IBGLIN=$G(^TMP($J,"IBCNOR4-1",2,IBNM))
.. I IBTYP=1&(IBGLIN<2) Q ; if doing all do not print group if only one insurance associated
.. S IBGNAM="" F S IBGNAM=$O(^TMP($J,"IBCNOR4-1",6,IBNM,IBGNAM)) Q:IBGNAM="" D
... S IBINS="" F S IBINS=$O(^TMP($J,"IBCNOR4-1",6,IBNM,IBGNAM,IBINS)) Q:IBINS="" D
.... S IBADDR="" F S IBADDR=$O(^TMP($J,"IBCNOR4-1",6,IBNM,IBGNAM,IBINS,IBADDR)) Q:IBADDR="" D
..... S IB3553="" F S IB3553=$O(^TMP($J,"IBCNOR4-1",6,IBNM,IBGNAM,IBINS,IBADDR,IB3553)) Q:IB3553="" D
...... S IBA=$G(^TMP($J,"IBCNOR4-1",6,IBNM,IBGNAM,IBINS,IBADDR,IB3553))
...... W !,$P(IBA,U,4),U,IBNM,U,IBGNAM,U,IBINS,U,IBADDR,U,$P(IBA,U,2),U,$P(IBA,U,3)
;
I IBOUT="R" D
. S IBNM="" F S IBNM=$O(^TMP($J,"IBCNOR4-1",1,IBNM)) Q:IBNM="" D Q:IBSTOP
.. S IBGLIN=$G(^TMP($J,"IBCNOR4-1",2,IBNM))
.. I IBTYP=1&(IBGLIN<2) Q ; if doing all do not print group if only one insurance associated
.. ; make sure to print at least one INS for the group on same page
.. I IBLNC+2>IBMAXCNT D QLINE Q:IBSTOP D:IBOUT="E" HDRE D:IBOUT="R" HDRR
.. W !,IBNM S IBLNC=IBLNC+1,IBGCT=0 ; print group number first
.. S IBINS="" F S IBINS=$O(^TMP($J,"IBCNOR4-1",1,IBNM,IBINS)) Q:IBINS="" D Q:IBSTOP
... S IBADDR="" F S IBADDR=$O(^TMP($J,"IBCNOR4-1",1,IBNM,IBINS,IBADDR)) Q:IBADDR="" D Q:IBSTOP
.... S IB3553="" F S IB3553=$O(^TMP($J,"IBCNOR4-1",1,IBNM,IBINS,IBADDR,IB3553)) Q:IB3553="" D Q:IBSTOP
..... S IBGCT=IBGCT+1,IBA=$G(^TMP($J,"IBCNOR4-1",1,IBNM,IBINS,IBADDR,IB3553))
..... S IBW=$S(IBOUT="E":$P(IBA,U,5),1:$P(IBA,U,4))_U_$P(IBA,U,3)_U_$P(IBA,U,2)
..... W !,?2,$P(IBA,U,6),?6,IBINS,?38,IBADDR,?74,$P(IBW,U,1),?83,$P(IBW,U,2),?107,$E($P(IBW,U,3),1,24)
..... S IBLNC=IBLNC+1
..... I (IBPGC>0),(IBLNC+1>IBMAXCNT) D
...... D QLINE Q:IBSTOP
...... D:IBOUT="E" HDRE D:IBOUT="R" HDRR
...... I IBGCT<IBGLIN W !,IBNM," (continued)"
I IBSTOP G EXITC
W !,IBEORMSG
D QLINE
;
;
EXITC ; compile section exit
;
K ^TMP($J,"IBCNOR4-1")
K ^TMP($J,"IBCNOR4")
Q
;
;
NOD ; no info to print
;
D:IBOUT="E" HDRE D:IBOUT="R" HDRR
W !,IBNONEMSG,!,IBEORMSG
D QLINE
Q
;
QLINE ; cr to continue
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LIN
W !
I 'IBCRT Q
S DIR(0)="E" D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT) S IBSTOP=1
Q
;
;
WALK(IBINDX,IBLS) ; get subscribers
;
N IB3553,IB36,IBA,IBARY,IBB,IBC,IBD,IBDTA,IBINAL1,IBINM,IBGNUM,IBSUBCT,IBPTDFN,IBPTINS
I IBCRT W !,"Gathering Subscriber Counts: ",!,"."
S IB36=0,IBCNT=0 F S IB36=$O(^TMP($J,"IBCNOR4",5,IB36)) Q:'IB36 D
. ;check pt file #2.312
. S IBPTDFN=0 F S IBPTDFN=$O(^DPT("AB",IB36,IBPTDFN)) Q:'IBPTDFN S IBPTINS=0 D
.. F S IBPTINS=$O(^DPT("AB",IB36,IBPTDFN,IBPTINS)) Q:'IBPTINS D
... S IBCNT=IBCNT+1 I IBCRT&(IBCNT#IBDOT=0) W "."
... S IBA=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",.18,"I")
... I 'IBA Q ; no group associated
... I '$D(^TMP($J,"IBCNOR4",5,IB36,IBA)) Q ; ins/group combo not selected
... S ^TMP($J,"IBCNOR4",5,IB36,IBA)=$G(^TMP($J,"IBCNOR4",5,IB36,IBA))+1
I IBCRT W !,"Placing Subscriber Totals: ",!,"."
; ^TMP(39151,"IBCNOR4",4, group number , insurance co name , ins co address line 1 , 355.3 IEN) =
; file 36 IEN ^ type of plan ^ group name with + or * as needed ^ subscriber count ^ sub ct no spaces ^ ins A or I
S (IBCHK,IBCNT)=0,IBGNUM="" F S IBGNUM=$O(^TMP($J,"IBCNOR4",4,IBGNUM)) Q:IBGNUM="" S IBINM="" D
. F S IBINM=$O(^TMP($J,"IBCNOR4",4,IBGNUM,IBINM)) Q:IBINM="" S IBINAL1="" D
.. F S IBINAL1=$O(^TMP($J,"IBCNOR4",4,IBGNUM,IBINM,IBINAL1)) Q:IBINAL1="" S IB3553=0 D
... F S IB3553=$O(^TMP($J,"IBCNOR4",4,IBGNUM,IBINM,IBINAL1,IB3553)) Q:'IB3553 D
.... I IBCRT&(IBCNT#30000=0) W "."
.... S IBDTA=$G(^TMP($J,"IBCNOR4",4,IBGNUM,IBINM,IBINAL1,IB3553))
.... S IB36=$P(IBDTA,U,1)
.... ; place total subscribers for each item
.... S IBSUBCT=$G(^TMP($J,"IBCNOR4",5,IB36,IB3553)),IBCNT=IBCNT+1
.... ;
.... S IBB=$FN(IBSUBCT,",",0)
.... S IBC=$E(IBSPACES,1,(7-$L(IBB)))_IBB,$P(IBDTA,U,4)=IBC,$P(IBDTA,U,5)=IBB
.... S ^TMP($J,"IBCNOR4-1",1,IBGNUM,IBINM,IBINAL1,IB3553)=IBDTA
.... S ^TMP($J,"IBCNOR4-1",2,IBGNUM)=$G(^TMP($J,"IBCNOR4-1",2,IBGNUM))+1 ; how many lines for the group number
.... S ^TMP($J,"IBCNOR4-1",2)=$G(^TMP($J,"IBCNOR4-1",2))+1
.... ; this is for the excel output since it is different for the report output
.... ; ins AorI , gp num , gp nam , ins nm , ins add l1 , 355.33 ien = ins ien ^ typ pln ^ tot sums
.... S ^TMP($J,"IBCNOR4-1",6,IBGNUM,$P(IBDTA,U,3),IBINM,IBINAL1,IB3553)=$P(IBDTA,U,1)_U_$P(IBDTA,U,2)_U_$P(IBDTA,U,5)_U_$P(IBDTA,U,6)
;
Q
;
RUN ; go through 355.3
;
N IB3553GNA,IB3553TY,IB36A1,IB36N,IB5,IBAR5,IBINA
S IBS3553="",IBCNT=0,IBCTL=0 F S IBS3553=$O(^IBA(355.3,IBS3553)) Q:IBS3553="" D
. S IBCNT=IBCNT+1 I IBCRT&(IBCNT#4000=0) W "."
. S IB36=$$GET1^DIQ(355.3,IBS3553_",",.01,"I") I 'IB36 Q ; if there is no insurance get next
. I '$D(^DIC(36,IB36,0)) Q ; if the pointer is invalid go back
. ; (#.01) INSURANCE COMPANY [1P:36]
. ; (#.02) IS THIS A GROUP POLICY? '1' FOR YES; '0' FOR NO
. ; (#.03) *GROUP NAME
. ; (#.04) *GROUP NUMBER
. ; (#.09) TYPE OF PLAN [9P:355.1]
. ; (#.11) INACTIVE '0' FOR NO; '1' FOR YES
. ; (#2.01) GROUP NAME
. ; (#2.02) GROUP NUMBER
. K IBAR5 D GETS^DIQ(355.3,IBS3553_",",".01;.02;.03;.04;.09;.11;2.01;2.02","IE","IBAR5")
. K IB5 M IB5=IBAR5(355.3,IBS3553_",")
. ; get group number
. S IBSI=$G(IB5(2.02,"I")) ; get group number from 'approved' group number field
. I IBSI="" S IBSI=$G(IB5(.04,"I")) ; get group number from 'old' field if 'approved' is null
. I IBSI="" Q ; no group number go back
. ; gety group name
. S IB3553GNA=$G(IB5(2.01,"I")) ; get group name from 'approved' group name field
. I IB3553GNA="" S IB3553GNA=$G(IB5(.03,"I")) ; get group name from 'old' field if approved is null
. I IB3553GNA="" S IB3553GNA="<NO GROUP NAME>" ; if no group name associated
. ; get type of plan
. S IB3553TY=$G(IB5(.09,"E"))
. I $L(IB3553TY)>25 S:IBOUT="R" IB3553TY=$E(IB3553TY,1,25) I $G(IB5(.09,"I"))'="" D
.. S:IBOUT="R" IB3553TY=$$GET1^DIQ(355.1,$G(IB5(.09,"I"))_",",.02) ; Abbreviation
. ; check if individual and if inactive
. S IBA="" S:'$G(IB5(.02,"I")) IBA="+" S:$G(IB5(.11,"I")) IBA=IBA_"*"
. S IB3553GNA=IBA_IB3553GNA
. ; file 36 info
. ; (#.01) INSURANCE COMPANY NAME
. ; (#.05) INACTIVE '0' FOR NO; '1' FOR YES
. ; (#.111) STREET ADDRESS [LINE 1]
. ; (#.13) TYPE OF COVERAGE [13P:355.2]
. K IBARY D GETS^DIQ(36,IB36_",",".01;.05;.111;.13","IE","IBARY")
. K IBW M IBW=IBARY(36,IB36_",")
. S IB36N=$G(IBW(.01,"E"))
. S IB36A1=$G(IBW(.111,"E")) S:IB36A1="" IB36A1=" " S IB36A1=$E(IB36A1,1,34)
. S IB36N=IB36N
. S IBA=$G(IBW(.05,"I")),IBINA=$S('IBA:"A",1:"I")
. I IBTYP=2 D Q
.. I $D(^TMP($J,"IBCNOR4","U",($$UP^XLFSTR(IBSI)))) D RSET
. D RSET
Q
;
RSET ; update TMP to prep for subscriber check
;
I '$D(^TMP($J,"IBCNOR4",1,IBSI)) S ^TMP($J,"IBCNOR4",1,IBSI)=2
S IBUN=$$UP^XLFSTR(IBSI),^TMP($J,"IBCNOR4",2,IBUN)=1
; G Nu in nm in addr 355 ien 38 ien typ pln g nm
S ^TMP($J,"IBCNOR4",4,IBSI,IB36N,IB36A1,IBS3553)=IB36_U_IB3553TY_U_IB3553GNA_U_U_U_IBINA
I IB36&(IBS3553) S ^TMP($J,"IBCNOR4",5,IB36,IBS3553)=0
I IBTYP=1 D
. S IBCTL=IBCTL+1,^TMP($J,"IBCNOR4",0)=IBCTL
Q
;
HDRE ; excel header
;
W !,IBHDRNAME,U,IBHDRDATE
W !,IBFILTER
W ", + Indicates individual group plan * Indicates inactive group plan"
W !,"A/I^GROUP NUMBER^GROUP NAME^INSURANCE COMPANY^ADDRESS^TYPE OF PLAN^TOTAL SUBSCRIBERS"
;
Q
;
HDRR ; report header
;
N IBA,IBF,IBG
S IBPGC=IBPGC+1,IBLNC=0 I IBCRT W:$G(IOF)'="" @IOF W:$G(IOF)="" ! S IBLNC=7
I 'IBCRT W !
S IBA=$E(IBSPACES,1,(6-$L(IBPGC)))_IBPGC
W IBHDRNAME,?92,IBHDRDATE,?119,"Page: ",IBA,!
S:IBLNC=0 IBLNC=6
W IBFILTER,?57,"+ Indicates individual group plan",?99,"* Indicates inactive group plan",!!
W "GROUP NUMBER",!
W ?2,"A/I",?6,"INSURANCE COMPANY",?38,"ADDRESS",?72,"TOTAL SUB",?83,"GROUP NAME",?107,"TYPE OF PLAN"
W !,$E(IBDASHES,1,132)
Q
;
STOP() ; Determine if user wants to exit out of the whole option
; Initialize Variables
N DIR,DIRUT,X,Y
W !
S DIR(0)="Y"
S DIR("A")="Do you want to exit out of this option entirely"
S DIR("B")="YES"
S DIR("?",1)=" Enter YES to immediately exit out of this option."
S DIR("?")=" Enter NO to return to the previous question."
D ^DIR K DIR
I $D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT) S (IBSTOP,Y)=1 G STOPX
I 'Y S IBSTOP=0
STOPX ; STOP Exit Point
Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNOR4 14309 printed Sep 11, 2024@02:36:03 Page 2
IBCNOR4 ;AITC/DTG - IBCN DUP GROUP TO INS USAGE ;12/14/23
+1 ;;2.0;INTEGRATED BILLING;**778**;21-MAR-94;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; entry point
+1 ;
+2 NEW DIR,IBAR,IBCK,IBCNT,IBI,IBID,IBOK,IBONE,IBOUT,IBSTOP,IBTYP,IBXSAV,POP,X,Y
+3 KILL ^TMP("IBCNOR4",$JOB)
SET ^TMP("IBCNOR4",$JOB,0)=""
+4 if $GET(IOF)'=""
WRITE @IOF
if $GET(IOF)=""
WRITE !
+5 WRITE !,"This report can help identify potential duplicate group plans by group"
+6 WRITE !,"number in one or more insurance companies. Search through the entire"
+7 WRITE !,"database for duplicate groups or narrow down the search by a specific"
+8 WRITE !,"group number."
+9 ; get group numbers
+10 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
ENTYP ; get type equal or contain or all
+1 ;
+2 WRITE !
SET IBTYP=""
+3 KILL DIR
SET DIR(0)="S^1:ALL Duplicate Groups;2:Specific Group Number"
+4 SET DIR("A")="SELECT 1 or 2"
+5 SET DIR("?",1)="All Duplicate Groups will search the entire database and if exact"
+6 SET DIR("?",2)="duplicates are found (by group number), all duplicate group results"
+7 SET DIR("?",3)="from all insurance companies will display on the report."
+8 SET DIR("?",4)=" "
+9 SET DIR("?",5)="Specific Group Number requires the user to enter a specific group"
+10 SET DIR("?",6)="number and will return all results of the searched group from all"
+11 SET DIR("?",7)="insurance companies (regardless of number of instances)."
+12 SET DIR("?")="Enter '^' to quit, OR"
+13 DO ^DIR
+14 IF Y=""
SET Y=1
+15 IF $EXTRACT(Y)=U!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)
SET Y="^"
+16 IF $EXTRACT(Y)=U
GOTO EXIT
+17 SET IBTYP=+Y
IF 'Y
GOTO EXIT
+18 ; if looking for all skip the group number question
IF IBTYP=1
GOTO CON
+19 ;
ENRK ; come here if continue from ^ response
+1 KILL ^TMP("IBCNOR4",$JOB)
SET ^TMP("IBCNOR4",$JOB,0)=""
ENR ; ask question return point.
+1 WRITE !
+2 KILL DIR
SET DIR(0)="F^1:30"
+3 SET DIR("A")="Enter a Group Number"
+4 SET DIR("?")="Enter a specific Group/Plan Number or '^' to quit"
+5 SET IBOK=0
ENAQ ;
+1 DO ^DIR
+2 ;
+3 IF $EXTRACT(Y,1)=" "
SET IBOK=0
Begin DoDot:1
+4 FOR IBI=1:1:$LENGTH(Y)
IF $EXTRACT(Y,IBI)'=" "
SET IBOK=1
QUIT
End DoDot:1
IF 'IBOK
SET Y=""
WRITE !,"This is a required response. Enter '^' to exit"
GOTO ENAQ
+5 IF $EXTRACT(Y)=U!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)
SET Y=U
+6 DO ISET
+7 IF $EXTRACT(Y)=U
GOTO EXIT
+8 GOTO RE
+9 ;
CON ; continue if all
+1 IF IBTYP'=1
GOTO RE
+2 WRITE !!!,"WARNING: You have selected to run this report for all duplicate groups."
+3 WRITE !,"In doing so, this report will take a long time to run.",!
+4 KILL DIR,DIRUT,DIROUT,DTOUT,DUOUT
+5 SET DIR(0)="Y"
+6 SET DIR("A")="Do you want to continue"
+7 SET DIR("B")="NO"
+8 SET DIR("?",1)=" Enter YES to continue."
+9 SET DIR("?")=" Enter NO or '^' to exit."
+10 DO ^DIR
KILL DIR
+11 ; do not wish to continue
IF 'Y
GOTO EXIT
+12 ;
RE ; report or excel
+1 SET IBSTOP=0
DO OUT
IF IBSTOP
GOTO EXIT
+2 ;
+3 DO DEVICE
+4 ;
EXIT ; quit point
+1 ;
+2 KILL ^TMP("IBCNOR4",$JOB)
+3 QUIT
+4 ;
+5 ;
ISET ; if item save and set flag
+1 ;
+2 NEW IBA,IBC,IBD,IBE,IBFND
+3 ; leave IBOK 0 in order to stop
IF Y=""!($EXTRACT(Y)=U)
QUIT
+4 SET ^TMP("IBCNOR4",$JOB,1,Y)=1
SET ^TMP("IBCNOR4",$JOB,0)=1
SET ^TMP("IBCNOR4",$JOB,"U",($$UP^XLFSTR(Y)))=1
+5 QUIT
+6 ;
OUT ; Prompt to allow users to select output format
+1 ; Returns: E - Output to excel
+2 ; R - Output to report
+3 ; IBSTOP=1 - No Selection made
+4 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+5 WRITE !
+6 SET DIR(0)="SA^E:Excel;R:Report"
+7 SET DIR("A")="(E)xcel Format or (R)eport Format: "
+8 SET DIR("B")="Report"
+9 SET DIR("?",1)="Select 'E' to create CSV output for import into Excel."
+10 SET DIR("?")="Select 'R' to create a standard report."
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)
SET IBSTOP=1
GOTO OUTQ
+13 SET IBOUT=Y
+14 QUIT
OUTQ ;
+1 ;
+2 QUIT
+3 ;
DEVICE ;
+1 NEW IBB,POP,ZTDESC,ZTRTN,ZTSAVE
+2 IF IBOUT="R"
WRITE !!,"***This report is 132 characters wide.***",!
+3 IF IBOUT="E"
Begin DoDot:1
+4 WRITE !!,"For CSV output, turn logging or capture on now.",!
+5 WRITE "To avoid undesired wrapping of the data, please"
+6 WRITE !," enter '0;256;99999'.",!
End DoDot:1
+7 KILL IBXSAV
MERGE IBXSAV=^TMP("IBCNOR4",$JOB)
+8 SET ZTRTN="COMPILE^IBCNOR4"
+9 SET ZTDESC="LD - LIST DUPLICATE GROUP PLANS BY INS CO"
+10 FOR IBB="IBOUT","IBTYP","IBXSAV("
SET ZTSAVE(IBB)=""
+11 ; ICR # 1519
DO EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,"Q")
+12 ;
+13 QUIT
+14 ;
+15 ;
COMPILE ; build output of payers
+1 ;
+2 NEW %,IB3553,IB36,IBA,IBADDR,IBARY,IBB,IBC,IBCTL,IBCHK,IBCNT,IBCRT,IBDASHES,IBDOT,IBEORMSG,IBFILTER
+3 NEW IBGCT,IBGNAM,IBGON,IBHDR
+4 NEW IBHDRDATE,IBHDRNAME,IBINDX,IBINS,IBITM,IBL,IBLOOK,IBLNC,IBLS,IBMAXCNT,IBNM,IBNONEMSG
+5 NEW IBPGC,IBS,IBS3553,IBSPACES,IBST,IBSTAB,IBSTOP,IBSI,IBSTOP,IBUN,IBW,IBXTFEED,IBZIP
+6 ;
+7 SET IBOUT=$GET(IBOUT)
+8 SET IBCHK=0
+9 SET IBMAXCNT=IOSL-3
SET IBXTFEED=21
SET IBCRT=1
SET IBLNC=0
+10 IF IOST'["C-"
SET IBMAXCNT=IOSL-6
SET IBXTFEED=50
SET IBCRT=0
+11 SET IBEORMSG="*** End of Report ***"
+12 SET IBNONEMSG="* * * N o D a t a F o u n d * * *"
+13 SET IBHDRNAME="List Duplicate Group Plans by Insurance Company"
+14 DO NOW^%DTC
+15 SET IBHDRDATE=$$DAT2^IBOUTL($EXTRACT(%,1,12))
+16 SET $PIECE(IBDASHES,"-",132)=""
+17 SET $PIECE(IBSPACES," ",80)=""
+18 SET IBHDR="HDR"_$SELECT(IBOUT="E":"E",1:"R")
+19 KILL ^TMP($JOB,"IBCNOR4")
+20 KILL ^TMP($JOB,"IBCNOR4-1")
+21 KILL IBFND
+22 MERGE ^TMP($JOB,"IBCNOR4")=IBXSAV
+23 ; reduce dots for subscribers when all are selected
SET IBDOT=2000
IF IBTYP=1
SET IBDOT=100000
+24 ;
+25 ;compile
+26 ; walk the indexes
+27 ;
+28 IF IBCRT
WRITE !,"Checking for Duplicate Group Number(s)",!
+29 SET IBFILTER=""
IF IBTYP=2
SET IBFILTER="Selected: "
+30 DO RUN
+31 ; if all collect all group numbers
+32 IF IBTYP=1
SET IBFILTER="All Group Numbers"
+33 IF IBTYP=2
SET IBLOOK=""
SET IBCNT=0
FOR
SET IBLOOK=$ORDER(^TMP($JOB,"IBCNOR4",1,IBLOOK))
if IBLOOK=""
QUIT
Begin DoDot:1
+34 SET IBB=$GET(^TMP($JOB,"IBCNOR4",1,IBLOOK))
IF IBB=1
SET IBFILTER=IBFILTER_($SELECT('+IBCHK:"",1:", "))_IBLOOK
SET IBCHK=IBCHK+1
End DoDot:1
+35 ;
+36 ; get subscriber counts
DO WALK
+37 ;
+38 ; uses ^TMP($J,"IBCNOR4-1") to print
+39 ;
PRINT ; out put the compile in insurance co name order
+1 ;
+2 NEW IBA,IBGLIN
+3 KILL IBW,IBARY
+4 SET IBSTOP=0
SET IBPGC=0
SET IBGCT=0
SET IBGON=""
+5 IF '+$GET(^TMP($JOB,"IBCNOR4-1",2))
DO NOD
GOTO EXITC
+6 if IBOUT="E"
DO HDRE
if IBOUT="R"
DO HDRR
+7 IF IBOUT="E"
Begin DoDot:1
+8 SET IBNM=""
FOR
SET IBNM=$ORDER(^TMP($JOB,"IBCNOR4-1",6,IBNM))
if IBNM=""
QUIT
Begin DoDot:2
+9 SET IBGLIN=$GET(^TMP($JOB,"IBCNOR4-1",2,IBNM))
+10 ; if doing all do not print group if only one insurance associated
IF IBTYP=1&(IBGLIN<2)
QUIT
+11 SET IBGNAM=""
FOR
SET IBGNAM=$ORDER(^TMP($JOB,"IBCNOR4-1",6,IBNM,IBGNAM))
if IBGNAM=""
QUIT
Begin DoDot:3
+12 SET IBINS=""
FOR
SET IBINS=$ORDER(^TMP($JOB,"IBCNOR4-1",6,IBNM,IBGNAM,IBINS))
if IBINS=""
QUIT
Begin DoDot:4
+13 SET IBADDR=""
FOR
SET IBADDR=$ORDER(^TMP($JOB,"IBCNOR4-1",6,IBNM,IBGNAM,IBINS,IBADDR))
if IBADDR=""
QUIT
Begin DoDot:5
+14 SET IB3553=""
FOR
SET IB3553=$ORDER(^TMP($JOB,"IBCNOR4-1",6,IBNM,IBGNAM,IBINS,IBADDR,IB3553))
if IB3553=""
QUIT
Begin DoDot:6
+15 SET IBA=$GET(^TMP($JOB,"IBCNOR4-1",6,IBNM,IBGNAM,IBINS,IBADDR,IB3553))
+16 WRITE !,$PIECE(IBA,U,4),U,IBNM,U,IBGNAM,U,IBINS,U,IBADDR,U,$PIECE(IBA,U,2),U,$PIECE(IBA,U,3)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+17 ;
+18 IF IBOUT="R"
Begin DoDot:1
+19 SET IBNM=""
FOR
SET IBNM=$ORDER(^TMP($JOB,"IBCNOR4-1",1,IBNM))
if IBNM=""
QUIT
Begin DoDot:2
+20 SET IBGLIN=$GET(^TMP($JOB,"IBCNOR4-1",2,IBNM))
+21 ; if doing all do not print group if only one insurance associated
IF IBTYP=1&(IBGLIN<2)
QUIT
+22 ; make sure to print at least one INS for the group on same page
+23 IF IBLNC+2>IBMAXCNT
DO QLINE
if IBSTOP
QUIT
if IBOUT="E"
DO HDRE
if IBOUT="R"
DO HDRR
+24 ; print group number first
WRITE !,IBNM
SET IBLNC=IBLNC+1
SET IBGCT=0
+25 SET IBINS=""
FOR
SET IBINS=$ORDER(^TMP($JOB,"IBCNOR4-1",1,IBNM,IBINS))
if IBINS=""
QUIT
Begin DoDot:3
+26 SET IBADDR=""
FOR
SET IBADDR=$ORDER(^TMP($JOB,"IBCNOR4-1",1,IBNM,IBINS,IBADDR))
if IBADDR=""
QUIT
Begin DoDot:4
+27 SET IB3553=""
FOR
SET IB3553=$ORDER(^TMP($JOB,"IBCNOR4-1",1,IBNM,IBINS,IBADDR,IB3553))
if IB3553=""
QUIT
Begin DoDot:5
+28 SET IBGCT=IBGCT+1
SET IBA=$GET(^TMP($JOB,"IBCNOR4-1",1,IBNM,IBINS,IBADDR,IB3553))
+29 SET IBW=$SELECT(IBOUT="E":$PIECE(IBA,U,5),1:$PIECE(IBA,U,4))_U_$PIECE(IBA,U,3)_U_$PIECE(IBA,U,2)
+30 WRITE !,?2,$PIECE(IBA,U,6),?6,IBINS,?38,IBADDR,?74,$PIECE(IBW,U,1),?83,$PIECE(IBW,U,2),?107,$EXTRACT($PIECE(IBW,U,3),1,24)
+31 SET IBLNC=IBLNC+1
+32 IF (IBPGC>0)
IF (IBLNC+1>IBMAXCNT)
Begin DoDot:6
+33 DO QLINE
if IBSTOP
QUIT
+34 if IBOUT="E"
DO HDRE
if IBOUT="R"
DO HDRR
+35 IF IBGCT<IBGLIN
WRITE !,IBNM," (continued)"
End DoDot:6
End DoDot:5
if IBSTOP
QUIT
End DoDot:4
if IBSTOP
QUIT
End DoDot:3
if IBSTOP
QUIT
End DoDot:2
if IBSTOP
QUIT
End DoDot:1
+36 IF IBSTOP
GOTO EXITC
+37 WRITE !,IBEORMSG
+38 DO QLINE
+39 ;
+40 ;
EXITC ; compile section exit
+1 ;
+2 KILL ^TMP($JOB,"IBCNOR4-1")
+3 KILL ^TMP($JOB,"IBCNOR4")
+4 QUIT
+5 ;
+6 ;
NOD ; no info to print
+1 ;
+2 if IBOUT="E"
DO HDRE
if IBOUT="R"
DO HDRR
+3 WRITE !,IBNONEMSG,!,IBEORMSG
+4 DO QLINE
+5 QUIT
+6 ;
QLINE ; cr to continue
+1 ;
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LIN
+3 WRITE !
+4 IF 'IBCRT
QUIT
+5 SET DIR(0)="E"
DO ^DIR
KILL DIR
+6 IF $DATA(DTOUT)!$DATA(DUOUT)
SET IBSTOP=1
+7 QUIT
+8 ;
+9 ;
WALK(IBINDX,IBLS) ; get subscribers
+1 ;
+2 NEW IB3553,IB36,IBA,IBARY,IBB,IBC,IBD,IBDTA,IBINAL1,IBINM,IBGNUM,IBSUBCT,IBPTDFN,IBPTINS
+3 IF IBCRT
WRITE !,"Gathering Subscriber Counts: ",!,"."
+4 SET IB36=0
SET IBCNT=0
FOR
SET IB36=$ORDER(^TMP($JOB,"IBCNOR4",5,IB36))
if 'IB36
QUIT
Begin DoDot:1
+5 ;check pt file #2.312
+6 SET IBPTDFN=0
FOR
SET IBPTDFN=$ORDER(^DPT("AB",IB36,IBPTDFN))
if 'IBPTDFN
QUIT
SET IBPTINS=0
Begin DoDot:2
+7 FOR
SET IBPTINS=$ORDER(^DPT("AB",IB36,IBPTDFN,IBPTINS))
if 'IBPTINS
QUIT
Begin DoDot:3
+8 SET IBCNT=IBCNT+1
IF IBCRT&(IBCNT#IBDOT=0)
WRITE "."
+9 SET IBA=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",.18,"I")
+10 ; no group associated
IF 'IBA
QUIT
+11 ; ins/group combo not selected
IF '$DATA(^TMP($JOB,"IBCNOR4",5,IB36,IBA))
QUIT
+12 SET ^TMP($JOB,"IBCNOR4",5,IB36,IBA)=$GET(^TMP($JOB,"IBCNOR4",5,IB36,IBA))+1
End DoDot:3
End DoDot:2
End DoDot:1
+13 IF IBCRT
WRITE !,"Placing Subscriber Totals: ",!,"."
+14 ; ^TMP(39151,"IBCNOR4",4, group number , insurance co name , ins co address line 1 , 355.3 IEN) =
+15 ; file 36 IEN ^ type of plan ^ group name with + or * as needed ^ subscriber count ^ sub ct no spaces ^ ins A or I
+16 SET (IBCHK,IBCNT)=0
SET IBGNUM=""
FOR
SET IBGNUM=$ORDER(^TMP($JOB,"IBCNOR4",4,IBGNUM))
if IBGNUM=""
QUIT
SET IBINM=""
Begin DoDot:1
+17 FOR
SET IBINM=$ORDER(^TMP($JOB,"IBCNOR4",4,IBGNUM,IBINM))
if IBINM=""
QUIT
SET IBINAL1=""
Begin DoDot:2
+18 FOR
SET IBINAL1=$ORDER(^TMP($JOB,"IBCNOR4",4,IBGNUM,IBINM,IBINAL1))
if IBINAL1=""
QUIT
SET IB3553=0
Begin DoDot:3
+19 FOR
SET IB3553=$ORDER(^TMP($JOB,"IBCNOR4",4,IBGNUM,IBINM,IBINAL1,IB3553))
if 'IB3553
QUIT
Begin DoDot:4
+20 IF IBCRT&(IBCNT#30000=0)
WRITE "."
+21 SET IBDTA=$GET(^TMP($JOB,"IBCNOR4",4,IBGNUM,IBINM,IBINAL1,IB3553))
+22 SET IB36=$PIECE(IBDTA,U,1)
+23 ; place total subscribers for each item
+24 SET IBSUBCT=$GET(^TMP($JOB,"IBCNOR4",5,IB36,IB3553))
SET IBCNT=IBCNT+1
+25 ;
+26 SET IBB=$FNUMBER(IBSUBCT,",",0)
+27 SET IBC=$EXTRACT(IBSPACES,1,(7-$LENGTH(IBB)))_IBB
SET $PIECE(IBDTA,U,4)=IBC
SET $PIECE(IBDTA,U,5)=IBB
+28 SET ^TMP($JOB,"IBCNOR4-1",1,IBGNUM,IBINM,IBINAL1,IB3553)=IBDTA
+29 ; how many lines for the group number
SET ^TMP($JOB,"IBCNOR4-1",2,IBGNUM)=$GET(^TMP($JOB,"IBCNOR4-1",2,IBGNUM))+1
+30 SET ^TMP($JOB,"IBCNOR4-1",2)=$GET(^TMP($JOB,"IBCNOR4-1",2))+1
+31 ; this is for the excel output since it is different for the report output
+32 ; ins AorI , gp num , gp nam , ins nm , ins add l1 , 355.33 ien = ins ien ^ typ pln ^ tot sums
+33 SET ^TMP($JOB,"IBCNOR4-1",6,IBGNUM,$PIECE(IBDTA,U,3),IBINM,IBINAL1,IB3553)=$PIECE(IBDTA,U,1)_U_$PIECE(IBDTA,U,2)_U_$PIECE(IBDTA,U,5)_U_$PIECE(IBDTA,U,6)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+34 ;
+35 QUIT
+36 ;
RUN ; go through 355.3
+1 ;
+2 NEW IB3553GNA,IB3553TY,IB36A1,IB36N,IB5,IBAR5,IBINA
+3 SET IBS3553=""
SET IBCNT=0
SET IBCTL=0
FOR
SET IBS3553=$ORDER(^IBA(355.3,IBS3553))
if IBS3553=""
QUIT
Begin DoDot:1
+4 SET IBCNT=IBCNT+1
IF IBCRT&(IBCNT#4000=0)
WRITE "."
+5 ; if there is no insurance get next
SET IB36=$$GET1^DIQ(355.3,IBS3553_",",.01,"I")
IF 'IB36
QUIT
+6 ; if the pointer is invalid go back
IF '$DATA(^DIC(36,IB36,0))
QUIT
+7 ; (#.01) INSURANCE COMPANY [1P:36]
+8 ; (#.02) IS THIS A GROUP POLICY? '1' FOR YES; '0' FOR NO
+9 ; (#.03) *GROUP NAME
+10 ; (#.04) *GROUP NUMBER
+11 ; (#.09) TYPE OF PLAN [9P:355.1]
+12 ; (#.11) INACTIVE '0' FOR NO; '1' FOR YES
+13 ; (#2.01) GROUP NAME
+14 ; (#2.02) GROUP NUMBER
+15 KILL IBAR5
DO GETS^DIQ(355.3,IBS3553_",",".01;.02;.03;.04;.09;.11;2.01;2.02","IE","IBAR5")
+16 KILL IB5
MERGE IB5=IBAR5(355.3,IBS3553_",")
+17 ; get group number
+18 ; get group number from 'approved' group number field
SET IBSI=$GET(IB5(2.02,"I"))
+19 ; get group number from 'old' field if 'approved' is null
IF IBSI=""
SET IBSI=$GET(IB5(.04,"I"))
+20 ; no group number go back
IF IBSI=""
QUIT
+21 ; gety group name
+22 ; get group name from 'approved' group name field
SET IB3553GNA=$GET(IB5(2.01,"I"))
+23 ; get group name from 'old' field if approved is null
IF IB3553GNA=""
SET IB3553GNA=$GET(IB5(.03,"I"))
+24 ; if no group name associated
IF IB3553GNA=""
SET IB3553GNA="<NO GROUP NAME>"
+25 ; get type of plan
+26 SET IB3553TY=$GET(IB5(.09,"E"))
+27 IF $LENGTH(IB3553TY)>25
if IBOUT="R"
SET IB3553TY=$EXTRACT(IB3553TY,1,25)
IF $GET(IB5(.09,"I"))'=""
Begin DoDot:2
+28 ; Abbreviation
if IBOUT="R"
SET IB3553TY=$$GET1^DIQ(355.1,$GET(IB5(.09,"I"))_",",.02)
End DoDot:2
+29 ; check if individual and if inactive
+30 SET IBA=""
if '$GET(IB5(.02,"I"))
SET IBA="+"
if $GET(IB5(.11,"I"))
SET IBA=IBA_"*"
+31 SET IB3553GNA=IBA_IB3553GNA
+32 ; file 36 info
+33 ; (#.01) INSURANCE COMPANY NAME
+34 ; (#.05) INACTIVE '0' FOR NO; '1' FOR YES
+35 ; (#.111) STREET ADDRESS [LINE 1]
+36 ; (#.13) TYPE OF COVERAGE [13P:355.2]
+37 KILL IBARY
DO GETS^DIQ(36,IB36_",",".01;.05;.111;.13","IE","IBARY")
+38 KILL IBW
MERGE IBW=IBARY(36,IB36_",")
+39 SET IB36N=$GET(IBW(.01,"E"))
+40 SET IB36A1=$GET(IBW(.111,"E"))
if IB36A1=""
SET IB36A1=" "
SET IB36A1=$EXTRACT(IB36A1,1,34)
+41 SET IB36N=IB36N
+42 SET IBA=$GET(IBW(.05,"I"))
SET IBINA=$SELECT('IBA:"A",1:"I")
+43 IF IBTYP=2
Begin DoDot:2
+44 IF $DATA(^TMP($JOB,"IBCNOR4","U",($$UP^XLFSTR(IBSI))))
DO RSET
End DoDot:2
QUIT
+45 DO RSET
End DoDot:1
+46 QUIT
+47 ;
RSET ; update TMP to prep for subscriber check
+1 ;
+2 IF '$DATA(^TMP($JOB,"IBCNOR4",1,IBSI))
SET ^TMP($JOB,"IBCNOR4",1,IBSI)=2
+3 SET IBUN=$$UP^XLFSTR(IBSI)
SET ^TMP($JOB,"IBCNOR4",2,IBUN)=1
+4 ; G Nu in nm in addr 355 ien 38 ien typ pln g nm
+5 SET ^TMP($JOB,"IBCNOR4",4,IBSI,IB36N,IB36A1,IBS3553)=IB36_U_IB3553TY_U_IB3553GNA_U_U_U_IBINA
+6 IF IB36&(IBS3553)
SET ^TMP($JOB,"IBCNOR4",5,IB36,IBS3553)=0
+7 IF IBTYP=1
Begin DoDot:1
+8 SET IBCTL=IBCTL+1
SET ^TMP($JOB,"IBCNOR4",0)=IBCTL
End DoDot:1
+9 QUIT
+10 ;
HDRE ; excel header
+1 ;
+2 WRITE !,IBHDRNAME,U,IBHDRDATE
+3 WRITE !,IBFILTER
+4 WRITE ", + Indicates individual group plan * Indicates inactive group plan"
+5 WRITE !,"A/I^GROUP NUMBER^GROUP NAME^INSURANCE COMPANY^ADDRESS^TYPE OF PLAN^TOTAL SUBSCRIBERS"
+6 ;
+7 QUIT
+8 ;
HDRR ; report header
+1 ;
+2 NEW IBA,IBF,IBG
+3 SET IBPGC=IBPGC+1
SET IBLNC=0
IF IBCRT
if $GET(IOF)'=""
WRITE @IOF
if $GET(IOF)=""
WRITE !
SET IBLNC=7
+4 IF 'IBCRT
WRITE !
+5 SET IBA=$EXTRACT(IBSPACES,1,(6-$LENGTH(IBPGC)))_IBPGC
+6 WRITE IBHDRNAME,?92,IBHDRDATE,?119,"Page: ",IBA,!
+7 if IBLNC=0
SET IBLNC=6
+8 WRITE IBFILTER,?57,"+ Indicates individual group plan",?99,"* Indicates inactive group plan",!!
+9 WRITE "GROUP NUMBER",!
+10 WRITE ?2,"A/I",?6,"INSURANCE COMPANY",?38,"ADDRESS",?72,"TOTAL SUB",?83,"GROUP NAME",?107,"TYPE OF PLAN"
+11 WRITE !,$EXTRACT(IBDASHES,1,132)
+12 QUIT
+13 ;
STOP() ; Determine if user wants to exit out of the whole option
+1 ; Initialize Variables
+2 NEW DIR,DIRUT,X,Y
+3 WRITE !
+4 SET DIR(0)="Y"
+5 SET DIR("A")="Do you want to exit out of this option entirely"
+6 SET DIR("B")="YES"
+7 SET DIR("?",1)=" Enter YES to immediately exit out of this option."
+8 SET DIR("?")=" Enter NO to return to the previous question."
+9 DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)!$DATA(DIROUT)!$DATA(DTOUT)!$DATA(DUOUT)
SET (IBSTOP,Y)=1
GOTO STOPX
+11 IF 'Y
SET IBSTOP=0
STOPX ; STOP Exit Point
+1 QUIT Y
+2 ;
