IBCNOR1A.m

IBCNOR1A ;AITC/DTG - PATIENT MISSING COVERAGE REPORT ;08/14/23

 ;;2.0;INTEGRATED BILLING;**771**;21-MAR-94;Build 26

 ;;Per VA Directive 6402, this routine should not be modified.

 ;

 Q

COMPILE(IBCNORRTN,IBCNOR) ; Entry Point called from EN^XUTMDEVQ.

 ; IBCNORRTN = Routine name for ^TMP($J,...

 ;    IBCNOR = Array of params

 ; Input:

 ; IBCNOR("IBI")  = select INS 0 some, 1 all

 ; IBCNOR("IBIA") = only 1-Active Insurance Companies

 ; IBCNOR("IBIG") = 0-Selected, 1-All Group Plans

 ; IBCNOR("IBIGA")= only 1-Active Group Plans

 ; IBCNOR("IBIGN")= 1-Group Name, 2-Group Number, 3-Both Group Name and Group Number

 ; IBCNOR("IBFIL")= A^B^C where"

 ;                    A - 1-Begin with, 2-Contains, 3-Range

 ;                    B - A=1 Begin with text, A=2 Contains text, A=3 Range start text

 ;                    C - only if A=3 Range End text

 ; IBCNOR("IBOUT")  E-EXCEL, R-REPORT

 ;

 ;

 ; Compile and Print Report

 N CRT,GDATA,GCT,GIEN,IBA,IBAR,IBC,IBCT,IBDOB,IBDOBI,IBEFFDT,IBEXPDT,IBIF,IBINS,IBITM,IBLNC,IBNA,IBNAM

 N IBNM,IBPGN,IBSSN,IBPTI,IBTMP,IBTYPE,IBXTFEED,ICT,IIEN,PLANOK,IBSCRCT,MAXCNT,X,Y

 ;

 S MAXCNT=IOSL-3,IBXTFEED=21,CRT=1,IBLNC=0

 I IOST'["C-" S MAXCNT=IOSL-6,IBXTFEED=50,CRT=0

 ; if selected insurances

 I 'IBCNOR("IBI") D

 . I $O(^TMP(IBJOB,"IBCNOR","FND",IBJOB,"INS","")) D

 . . K ^TMP("IBCNOR",$J,"INS") M ^TMP("IBCNOR",$J,"INS")=^TMP(IBJOB,"IBCNOR","FND")

 . I IBCNOR("IBIG") D

 . . D BLDINSGR^IBCNOR1  ; build insurance groups

 ;

 ; If ALL Insurance Companies, add to ^TMP("IBCNOR")

 I IBCNOR("IBI") D

 . S IIEN=0,INSCT=0 F  S IIEN=$O(^DIC(36,IIEN)) Q:'IIEN  D

 . . ; check insurance

 . . S INACT=+$$GET1^DIQ(36,IIEN_",",.05,"I") ;1=Inactive, 0=Active

 . . I INACT Q  ; only select active insurances

 . . S IBINAME=$$GET1^DIQ(36,IIEN_",",.01,"I")

 . . S IBOK=1 D CHKNM^IBCNOR1(IBINAME) Q:'IBOK  ; do not select if name is on exclusion list

 . . S INSCT=INSCT+1

 . . S ^TMP("IBCNOR",$J,"INS",INSCT)=IIEN

 . I $G(IOST)["C-" W !,"Build Insurance Groups...",!

 . D BLDINSGR^IBCNOR1  ; build insurance groups

 ;

 ;

 ; collect patients

 I $G(IOST)["C-" W !,"Collecting Subscribers ...",!

 D BLDPT  ; collect all patients (subscribers) associated to insurance / groups

 ;

 S IBSCRCT=0

 K ^TMP($J,"PR")

 ;

 S IBTMP="^TMP(""IBCNOR"","_$J_")"

 ; build pt list of insurances

 S IBPTI=0,IBCT=0 K @IBTMP@("OUT")

 I $G(IOST)["C-" W !,"Building Output ...",!

 F  S IBPTI=$O(@IBTMP@("P-PT",IBPTI)) Q:'IBPTI  K ^TMP($J,"PR") D  D COMPF

 . ; PT name

 . S IBITM=$G(@IBTMP@("P-PT",IBPTI))

 . S IBNAM=$P(IBITM,U,1)

 . S:IBNAM="" IBNAM="<Pt. "_IBPTI_" Name Missing>"

 . ; Retrieve last 4 of SSN (last 5 if pseudo SSN)

 .S X=$$GET1^DIQ(2,IBPTI_",",.09,"I")         ; Patient's SSN

 .S X=$S($E(X,$L(X))="P":$E(X,$L(X)-4,$L(X)),1:$E(X,$L(X)-3,$L(X)))

 .S IBSSN=X

 .S IBDOBI=$$GET1^DIQ(2,IBPTI_",",.03,"I"),IBDOB=$$DTC(IBDOBI)         ; Patient's DOB

 . ;

 . S IBIF=0 F  S IBIF=$O(^DPT(IBPTI,.312,IBIF)) Q:'IBIF  D

 . . ;

 . . S IBCT=IBCT+1 I $G(IOST)["C-"&(IBCT#1000=0) W "."

 . . ;

 . . K IBAR S IBA=IBIF_","_IBPTI_"," D GETS^DIQ(2.312,IBA,".01;8;3","EI","IBAR")

 . . S IBI36=$G(IBAR(2.312,IBA,.01,"I")) I 'IBI36 Q  ; if no insurance go back

 . . S IBNM=$G(IBAR(2.312,IBA,.01,"E"))

 . . S IBOK=1 D CHKNM^IBCNOR1(IBNM) I 'IBOK Q  ; insurance name was restricted

 . . S IBOK=1 D CHKINS^IBCNOR1(IBI36) I 'IBOK Q  ; insurance type not allowed or ins is inactive

 . . ; is pt insurance active

 . . S IBEFFDT=$G(IBAR(2.312,IBA,8,"I"))  ; Effective Date

 . . S IBEXPDT=$G(IBAR(2.312,IBA,3,"I"))  ; Expiration Date

 . . I IBEFFDT="" Q  ; if the effective date is null it is inactive

 . . I (IBEFFDT&(IBEFFDT>DT)) Q  ; if a valid effective date and the date is greater than today it is inactive

 . . I (IBEXPDT&(IBEXPDT<DT)) Q  ; if the expiration date is less than today it is inactive

 . . S IBTYPE=$$GET1^DIQ(36,IBI36_",",.13,"E")

 . . ;

 . . ;  PT DFN ^ .312 RECID ^ INS NAME ^INSURANCE TYPE ^ EFFECTIVE DATE ^ EXPIRE DATE ^ PT NAME ^ PT SSN ^ PT DOB ^ INTERNAL DOB

 . . S ^TMP($J,"PR",IBPTI,IBI36)=IBI36_U_IBIF_U_IBNM_U_IBTYPE_U_IBEFFDT_U_IBEXPDT_U_IBNAM_U_IBSSN_U_IBDOB_U_IBDOBI

 . . S IBC=$G(^TMP($J,"PR",IBPTI,0)),IBC=IBC+1,^TMP($J,"PR",IBPTI,0)=IBC

 ;

 G PRINT

 ;

COMPF ; process the found items

 ;

 N IBA,IBB,IBC,IBD,IBE,IBF,IBPHM,IBQ

 I '+$G(^TMP($J,"PR",IBPTI,0)) Q  ; no active insurances left

 S IBQ=0 I +$G(^TMP($J,"PR",IBPTI,0))=1 D  I IBQ Q

 . S IBA=$O(^TMP($J,"PR",IBPTI,0))

 . S IBD=$G(^TMP($J,"PR",IBPTI,IBA)) I $P(IBD,U,4)="PRESCRIPTION ONLY" S IBQ=1

 S IBA=0,IBPHM=1

 F  S IBA=$O(^TMP($J,"PR",IBPTI,IBA)) Q:'IBA  D  Q:'IBPHM

 . S IBB=$G(^TMP($J,"PR",IBPTI,IBA))

 . S IBC=$P(IBB,U,3)

 . S IBD=$P(IBB,U,4)

 . S IBE=$P(IBB,U,10)  ; internal pt dob

 . I IBD["PRESCRIPTION ONLY" S IBPHM=0

 I IBPHM D

 . S @IBTMP@("OUT",IBNAM,IBDOBI)=IBPTI_U_IBSSN_U_IBDOB

 . S IBF=$G(@IBTMP@("OUT",0))+1,@IBTMP@("OUT",0)=IBF

 Q

 ;

PRINT ; print out

 ;

 N EORMSG,HDRDATE,HDRNAME,NONEMSG,IBDATA,IBDASHES,IBDFN,IBDOB,IBDOBI,IBEORM,IBPGC,IBPTNM,IBSPACES,IBT

 S IBT=$E($G(IBCNOR("IBOUT")),1) S:IBT'="R"&(IBT'="E") IBT="R"

 S IBPGC=0,IBEORM=0

 S EORMSG="*** End of Report ***"

 S NONEMSG="* * * N o   D a t a   F o u n d * * *"

 S HDRNAME="PATIENT MISSING COVERAGE REPORT"

 D NOW^%DTC

 S HDRDATE=$$DAT2^IBOUTL($E(%,1,12))

 S $P(IBDASHES,"-",80)=""

 S $P(IBSPACES," ",80)=""

 S IBLNC=0

 W !   ; add line between 'waiting dots' when compiling and the printing of the rpt

 D EHDR:IBT="E",HDR:IBT="R"

 I '+$G(^TMP("IBCNOR",$J,"OUT",0)) D  G EXIT

 . W !,NONEMSG,!,EORMSG

 . S IBLNC=IBLNC+2,IBEORM=1

 . D QLINE

 ; loop

 S IBPTNM=""

P1 S IBPTNM=$O(@IBTMP@("OUT",IBPTNM)) I IBPTNM="" W !,EORMSG S IBLNC=IBLNC+2,IBEORM=1 D QLINE G EXIT

 S IBDOBI=""

P2 S IBDOBI=$O(@IBTMP@("OUT",IBPTNM,IBDOBI)) I 'IBDOBI G P1

 S IBDATA=$G(@IBTMP@("OUT",IBPTNM,IBDOBI)),IBLNC=IBLNC+1

 I IBT="R" S IBSTOP=0 D  I IBSTOP G EXIT

 . W !,IBPTNM,?32,$P(IBDATA,U,3),?48,$P(IBDATA,U,2)

 . I (IBPGC>0),(IBLNC+1>MAXCNT) D

 . . D QLINE Q:IBSTOP

 . . D HDR

 I IBT="E" D

 . W !,IBPTNM,U,$P(IBDATA,U,3),U,$P(IBDATA,U,2)

 ;

 G P2

 ;

EHDR ; EXCEL header

 ;

 S IBPGC=IBPGC+1,IBLNC=2

 W !,HDRNAME_U_HDRDATE

 I IBPGC=1 D

 . W !,"Filters: ",$S(IBCNOR("IBI")=1:"All",1:"Selected")," Insurances, "

 . W $S(IBCNOR("IBIG")=1:"All",1:"Selected")," Group Plans"

 . W " ,NAME Between ",$S(IBRF="":"'FIRST'",1:IBRF)," and ",$S(IBRL="zzzzzz":"'LAST'",1:IBRL)

 . S IBLNC=4

 W !,"Patient Name"_U_"DOB"_U_"SSN"

 Q

 ;

HDR ; report header

 ;

 N IBA,IBF,IBG

 S IBPGC=IBPGC+1 W:$G(IOF)'="" @IOF W:$G(IOF)="" !

 S IBA=$E(IBSPACES,1,(4-$L(IBPGC)))_IBPGC,IBLNC=4

 W HDRNAME,?40,HDRDATE,?69,"Page: ",IBA,!

 I IBPGC=1 D

 . S IBLNC=5,IBF="Filters: "_$S(IBCNOR("IBI")=1:"All",1:"Selected")_" Insurances, "

 . S IBF=IBF_$S(IBCNOR("IBIG")=1:"All",1:"Selected")_" Group Plans"

 . S IBG="NAME Between "_$S(IBRF="":"'FIRST'",1:IBRF)_" and "_$S(IBRL="zzzzzz":"'LAST'",1:IBRL)

 . W IBF

 . I ($L(IBF)+($L(IBG)+2)>80) W ! S IBLNC=6

 . E  W ", "

 . W IBG,!

 W !,"Patient Name",?32,"DOB",?48,"SSN"

 W !,$E(IBDASHES,1,79)

 Q

 ;

EXIT ; leave option

 ;

 K ^TMP($J)

 K @IBTMP

 K ^TMP(IBJOB,"IBCNOR")

 ;

 Q

 ;

QLINE ; cr to continue

 ;

 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LIN

 I MAXCNT<51&('IBEORM) F LIN=1:1:(IBXTFEED-IBLNC) W !

 I 'CRT Q

 S DIR(0)="E" D ^DIR K DIR

 I $D(DTOUT)!$D(DUOUT) S IBSTOP=1

 Q

 ;

DTC(IBDTCK) ; check date return external if valid

 ;

 N IBDT,IBBK S IBDT=""

 I 'IBDTCK G DTCO

 S IBBK=$$VALIDDT^IBCNINSU($P(IBDTCK,".",1))

 I IBBK="-1"!(IBBK="") G DTCO

 S IBDT=$$FMTE^XLFDT(IBBK,"5DZ")

 I IBDT="00/00/00" S IBDT=""

 G DTCO

 ;

DTCO ; date check exit

 ;

 Q IBDT

 ;

BLDPT ; collect the subscribers for the policies/groups

 ;

 N IBA,IBAR35,IBC,IBCT,IBDTH,IBF,IBFC,IBGC,IB3553,IB36,IBIN,IBPNM,IBPNMA,IBPTDFN,IBPTINS

 ;

 ; clear found patients

 K ^TMP("IBCNOR",$J,"P-PT")

 S IBC=0,IBF=0,IBCT=0,IBFC=0

 F  S IBC=$O(^TMP("IBCNOR",$J,"INS",IBC)) Q:'IBC  S IB36=$G(^TMP("IBCNOR",$J,"INS",IBC)) I IB36 D

 . S IBGC=0 K IBAR35

 . F  S IBGC=$O(^TMP("IBCNOR",$J,"INS",IBC,"GRP",IBGC)) Q:'IBGC  D

 . . S IB3553=$G(^TMP("IBCNOR",$J,"INS",IBC,"GRP",IBGC)) I IB3553 S IBAR35(IB3553)=1

 . ; walk patient file for found combos.

 . S IBPTDFN=0,IBF=0 F  S IBPTDFN=$O(^DPT("AB",IB36,IBPTDFN)) Q:'IBPTDFN  S IBPTINS=0 D

 . . ;

 . . I $G(^TMP("IBCNOR",$J,"P-PT",IBPTDFN))'="" Q  ; only put pt in list once

 . . ;

 . . S IBDTH="",IBDTH=$$GET1^DIQ(2,IBPTDFN_",",.351) I IBDTH'="" Q  ; only look at living patients

 . . S IBPNM=$$GET1^DIQ(2,IBPTDFN_",",.01,"E"),IBPNMA=$$UP^XLFSTR(IBPNM)

 . . F  S IBPTINS=$O(^DPT("AB",IB36,IBPTDFN,IBPTINS)) Q:'IBPTINS  D  Q:IBF

 . . . S IBCT=IBCT+1  I $G(IOST)["C-" W:IBCT#2000=0 "."

 . . . S IBA=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",.18,"I") I IBA D

 . . . . I $G(IBAR35(IBA))'=1 Q

 . . . . I $G(^TMP("IBCNOR",$J,"P-PT",IBPTDFN))'="" Q  ; only put pt in list once

 . . . . I $E(IBPNM,1,$L(IBRLU))]IBRLU Q

 . . . . I IBRFU]$E(IBPNM,1,$L(IBRFU)) Q

 . . . . ; NM from DPT ^ ins ien ^ group ien ^ NM uppercase

 . . . . S ^TMP("IBCNOR",$J,"P-PT",IBPTDFN)=IBPNM_U_IB36_U_IB3553_U_IBPNMA,IBF=1

 . . . . S IBFC=$G(^TMP("IBCNOR",$J,"P-PT",0))+1,^TMP("IBCNOR",$J,"P-PT",0)=IBFC

 S $P(^TMP("IBCNOR",$J,"P-PT",0),U,2)=+$G(IBCT)

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBCNOR1A   9293     printed  Mar 13, 2025@21:21:03                                                                                                                                                                                                    Page 2

IBCNOR1A  ;AITC/DTG - PATIENT MISSING COVERAGE REPORT ;08/14/23

 +1       ;;2.0;INTEGRATED BILLING;**771**;21-MAR-94;Build 26

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4        QUIT 

COMPILE(IBCNORRTN,IBCNOR) ; Entry Point called from EN^XUTMDEVQ.

 +1       ; IBCNORRTN = Routine name for ^TMP($J,...

 +2       ;    IBCNOR = Array of params

 +3       ; Input:

 +4       ; IBCNOR("IBI")  = select INS 0 some, 1 all

 +5       ; IBCNOR("IBIA") = only 1-Active Insurance Companies

 +6       ; IBCNOR("IBIG") = 0-Selected, 1-All Group Plans

 +7       ; IBCNOR("IBIGA")= only 1-Active Group Plans

 +8       ; IBCNOR("IBIGN")= 1-Group Name, 2-Group Number, 3-Both Group Name and Group Number

 +9       ; IBCNOR("IBFIL")= A^B^C where"

 +10      ;                    A - 1-Begin with, 2-Contains, 3-Range

 +11      ;                    B - A=1 Begin with text, A=2 Contains text, A=3 Range start text

 +12      ;                    C - only if A=3 Range End text

 +13      ; IBCNOR("IBOUT")  E-EXCEL, R-REPORT

 +14      ;

 +15      ;

 +16      ; Compile and Print Report

 +17       NEW CRT,GDATA,GCT,GIEN,IBA,IBAR,IBC,IBCT,IBDOB,IBDOBI,IBEFFDT,IBEXPDT,IBIF,IBINS,IBITM,IBLNC,IBNA,IBNAM

 +18       NEW IBNM,IBPGN,IBSSN,IBPTI,IBTMP,IBTYPE,IBXTFEED,ICT,IIEN,PLANOK,IBSCRCT,MAXCNT,X,Y

 +19      ;

 +20       SET MAXCNT=IOSL-3

           SET IBXTFEED=21

           SET CRT=1

           SET IBLNC=0

 +21       IF IOST'["C-"

               SET MAXCNT=IOSL-6

               SET IBXTFEED=50

               SET CRT=0

 +22      ; if selected insurances

 +23       IF 'IBCNOR("IBI")

               Begin DoDot:1

 +24               IF $ORDER(^TMP(IBJOB,"IBCNOR","FND",IBJOB,"INS",""))

                       Begin DoDot:2

 +25                       KILL ^TMP("IBCNOR",$JOB,"INS")

                           MERGE ^TMP("IBCNOR",$JOB,"INS")=^TMP(IBJOB,"IBCNOR","FND")

                       End DoDot:2

 +26               IF IBCNOR("IBIG")

                       Begin DoDot:2

 +27      ; build insurance groups

                           DO BLDINSGR^IBCNOR1

                       End DoDot:2

               End DoDot:1

 +28      ;

 +29      ; If ALL Insurance Companies, add to ^TMP("IBCNOR")

 +30       IF IBCNOR("IBI")

               Begin DoDot:1

 +31               SET IIEN=0

                   SET INSCT=0

                   FOR 

                       SET IIEN=$ORDER(^DIC(36,IIEN))

                       if 'IIEN

                           QUIT 

                       Begin DoDot:2

 +32      ; check insurance

 +33      ;1=Inactive, 0=Active

                           SET INACT=+$$GET1^DIQ(36,IIEN_",",.05,"I")

 +34      ; only select active insurances

                           IF INACT

                               QUIT 

 +35                       SET IBINAME=$$GET1^DIQ(36,IIEN_",",.01,"I")

 +36      ; do not select if name is on exclusion list

                           SET IBOK=1

                           DO CHKNM^IBCNOR1(IBINAME)

                           if 'IBOK

                               QUIT 

 +37                       SET INSCT=INSCT+1

 +38                       SET ^TMP("IBCNOR",$JOB,"INS",INSCT)=IIEN

                       End DoDot:2

 +39               IF $GET(IOST)["C-"

                       WRITE !,"Build Insurance Groups...",!

 +40      ; build insurance groups

                   DO BLDINSGR^IBCNOR1

               End DoDot:1

 +41      ;

 +42      ;

 +43      ; collect patients

 +44       IF $GET(IOST)["C-"

               WRITE !,"Collecting Subscribers ...",!

 +45      ; collect all patients (subscribers) associated to insurance / groups

           DO BLDPT

 +46      ;

 +47       SET IBSCRCT=0

 +48       KILL ^TMP($JOB,"PR")

 +49      ;

 +50       SET IBTMP="^TMP(""IBCNOR"","_$JOB_")"

 +51      ; build pt list of insurances

 +52       SET IBPTI=0

           SET IBCT=0

           KILL @IBTMP@("OUT")

 +53       IF $GET(IOST)["C-"

               WRITE !,"Building Output ...",!

 +54       FOR 

               SET IBPTI=$ORDER(@IBTMP@("P-PT",IBPTI))

               if 'IBPTI

                   QUIT 

               KILL ^TMP($JOB,"PR")

               Begin DoDot:1

 +55      ; PT name

 +56               SET IBITM=$GET(@IBTMP@("P-PT",IBPTI))

 +57               SET IBNAM=$PIECE(IBITM,U,1)

 +58               if IBNAM=""

                       SET IBNAM="<Pt. "_IBPTI_" Name Missing>"

 +59      ; Retrieve last 4 of SSN (last 5 if pseudo SSN)

 +60      ; Patient's SSN

                   SET X=$$GET1^DIQ(2,IBPTI_",",.09,"I")

 +61               SET X=$SELECT($EXTRACT(X,$LENGTH(X))="P":$EXTRACT(X,$LENGTH(X)-4,$LENGTH(X)),1:$EXTRACT(X,$LENGTH(X)-3,$LENGTH(X)))

 +62               SET IBSSN=X

 +63      ; Patient's DOB

                   SET IBDOBI=$$GET1^DIQ(2,IBPTI_",",.03,"I")

                   SET IBDOB=$$DTC(IBDOBI)

 +64      ;

 +65               SET IBIF=0

                   FOR 

                       SET IBIF=$ORDER(^DPT(IBPTI,.312,IBIF))

                       if 'IBIF

                           QUIT 

                       Begin DoDot:2

 +66      ;

 +67                       SET IBCT=IBCT+1

                           IF $GET(IOST)["C-"&(IBCT#1000=0)

                               WRITE "."

 +68      ;

 +69                       KILL IBAR

                           SET IBA=IBIF_","_IBPTI_","

                           DO GETS^DIQ(2.312,IBA,".01;8;3","EI","IBAR")

 +70      ; if no insurance go back

                           SET IBI36=$GET(IBAR(2.312,IBA,.01,"I"))

                           IF 'IBI36

                               QUIT 

 +71                       SET IBNM=$GET(IBAR(2.312,IBA,.01,"E"))

 +72      ; insurance name was restricted

                           SET IBOK=1

                           DO CHKNM^IBCNOR1(IBNM)

                           IF 'IBOK

                               QUIT 

 +73      ; insurance type not allowed or ins is inactive

                           SET IBOK=1

                           DO CHKINS^IBCNOR1(IBI36)

                           IF 'IBOK

                               QUIT 

 +74      ; is pt insurance active

 +75      ; Effective Date

                           SET IBEFFDT=$GET(IBAR(2.312,IBA,8,"I"))

 +76      ; Expiration Date

                           SET IBEXPDT=$GET(IBAR(2.312,IBA,3,"I"))

 +77      ; if the effective date is null it is inactive

                           IF IBEFFDT=""

                               QUIT 

 +78      ; if a valid effective date and the date is greater than today it is inactive

                           IF (IBEFFDT&(IBEFFDT>DT))

                               QUIT 

 +79      ; if the expiration date is less than today it is inactive

                           IF (IBEXPDT&(IBEXPDT<DT))

                               QUIT 

 +80                       SET IBTYPE=$$GET1^DIQ(36,IBI36_",",.13,"E")

 +81      ;

 +82      ;  PT DFN ^ .312 RECID ^ INS NAME ^INSURANCE TYPE ^ EFFECTIVE DATE ^ EXPIRE DATE ^ PT NAME ^ PT SSN ^ PT DOB ^ INTERNAL DOB

 +83                       SET ^TMP($JOB,"PR",IBPTI,IBI36)=IBI36_U_IBIF_U_IBNM_U_IBTYPE_U_IBEFFDT_U_IBEXPDT_U_IBNAM_U_IBSSN_U_IBDOB_U_IBDOBI

 +84                       SET IBC=$GET(^TMP($JOB,"PR",IBPTI,0))

                           SET IBC=IBC+1

                           SET ^TMP($JOB,"PR",IBPTI,0)=IBC

                       End DoDot:2

               End DoDot:1

               DO COMPF

 +85      ;

 +86       GOTO PRINT

 +87      ;

COMPF     ; process the found items

 +1       ;

 +2        NEW IBA,IBB,IBC,IBD,IBE,IBF,IBPHM,IBQ

 +3       ; no active insurances left

           IF '+$GET(^TMP($JOB,"PR",IBPTI,0))

               QUIT 

 +4        SET IBQ=0

           IF +$GET(^TMP($JOB,"PR",IBPTI,0))=1

               Begin DoDot:1

 +5                SET IBA=$ORDER(^TMP($JOB,"PR",IBPTI,0))

 +6                SET IBD=$GET(^TMP($JOB,"PR",IBPTI,IBA))

                   IF $PIECE(IBD,U,4)="PRESCRIPTION ONLY"

                       SET IBQ=1

               End DoDot:1

               IF IBQ

                   QUIT 

 +7        SET IBA=0

           SET IBPHM=1

 +8        FOR 

               SET IBA=$ORDER(^TMP($JOB,"PR",IBPTI,IBA))

               if 'IBA

                   QUIT 

               Begin DoDot:1

 +9                SET IBB=$GET(^TMP($JOB,"PR",IBPTI,IBA))

 +10               SET IBC=$PIECE(IBB,U,3)

 +11               SET IBD=$PIECE(IBB,U,4)

 +12      ; internal pt dob

                   SET IBE=$PIECE(IBB,U,10)

 +13               IF IBD["PRESCRIPTION ONLY"

                       SET IBPHM=0

               End DoDot:1

               if 'IBPHM

                   QUIT 

 +14       IF IBPHM

               Begin DoDot:1

 +15               SET @IBTMP@("OUT",IBNAM,IBDOBI)=IBPTI_U_IBSSN_U_IBDOB

 +16               SET IBF=$GET(@IBTMP@("OUT",0))+1

                   SET @IBTMP@("OUT",0)=IBF

               End DoDot:1

 +17       QUIT 

 +18      ;

PRINT     ; print out

 +1       ;

 +2        NEW EORMSG,HDRDATE,HDRNAME,NONEMSG,IBDATA,IBDASHES,IBDFN,IBDOB,IBDOBI,IBEORM,IBPGC,IBPTNM,IBSPACES,IBT

 +3        SET IBT=$EXTRACT($GET(IBCNOR("IBOUT")),1)

           if IBT'="R"&(IBT'="E")

               SET IBT="R"

 +4        SET IBPGC=0

           SET IBEORM=0

 +5        SET EORMSG="*** End of Report ***"

 +6        SET NONEMSG="* * * N o   D a t a   F o u n d * * *"

 +7        SET HDRNAME="PATIENT MISSING COVERAGE REPORT"

 +8        DO NOW^%DTC

 +9        SET HDRDATE=$$DAT2^IBOUTL($EXTRACT(%,1,12))

 +10       SET $PIECE(IBDASHES,"-",80)=""

 +11       SET $PIECE(IBSPACES," ",80)=""

 +12       SET IBLNC=0

 +13      ; add line between 'waiting dots' when compiling and the printing of the rpt

           WRITE !

 +14       if IBT="E"

               DO EHDR

           if IBT="R"

               DO HDR

 +15       IF '+$GET(^TMP("IBCNOR",$JOB,"OUT",0))

               Begin DoDot:1

 +16               WRITE !,NONEMSG,!,EORMSG

 +17               SET IBLNC=IBLNC+2

                   SET IBEORM=1

 +18               DO QLINE

               End DoDot:1

               GOTO EXIT

 +19      ; loop

 +20       SET IBPTNM=""

P1         SET IBPTNM=$ORDER(@IBTMP@("OUT",IBPTNM))

           IF IBPTNM=""

               WRITE !,EORMSG

               SET IBLNC=IBLNC+2

               SET IBEORM=1

               DO QLINE

               GOTO EXIT

 +1        SET IBDOBI=""

P2         SET IBDOBI=$ORDER(@IBTMP@("OUT",IBPTNM,IBDOBI))

           IF 'IBDOBI

               GOTO P1

 +1        SET IBDATA=$GET(@IBTMP@("OUT",IBPTNM,IBDOBI))

           SET IBLNC=IBLNC+1

 +2        IF IBT="R"

               SET IBSTOP=0

               Begin DoDot:1

 +3                WRITE !,IBPTNM,?32,$PIECE(IBDATA,U,3),?48,$PIECE(IBDATA,U,2)

 +4                IF (IBPGC>0)

                       IF (IBLNC+1>MAXCNT)

                           Begin DoDot:2

 +5                            DO QLINE

                               if IBSTOP

                                   QUIT 

 +6                            DO HDR

                           End DoDot:2

               End DoDot:1

               IF IBSTOP

                   GOTO EXIT

 +7        IF IBT="E"

               Begin DoDot:1

 +8                WRITE !,IBPTNM,U,$PIECE(IBDATA,U,3),U,$PIECE(IBDATA,U,2)

               End DoDot:1

 +9       ;

 +10       GOTO P2

 +11      ;

EHDR      ; EXCEL header

 +1       ;

 +2        SET IBPGC=IBPGC+1

           SET IBLNC=2

 +3        WRITE !,HDRNAME_U_HDRDATE

 +4        IF IBPGC=1

               Begin DoDot:1

 +5                WRITE !,"Filters: ",$SELECT(IBCNOR("IBI")=1:"All",1:"Selected")," Insurances, "

 +6                WRITE $SELECT(IBCNOR("IBIG")=1:"All",1:"Selected")," Group Plans"

 +7                WRITE " ,NAME Between ",$SELECT(IBRF="":"'FIRST'",1:IBRF)," and ",$SELECT(IBRL="zzzzzz":"'LAST'",1:IBRL)

 +8                SET IBLNC=4

               End DoDot:1

 +9        WRITE !,"Patient Name"_U_"DOB"_U_"SSN"

 +10       QUIT 

 +11      ;

HDR       ; report header

 +1       ;

 +2        NEW IBA,IBF,IBG

 +3        SET IBPGC=IBPGC+1

           if $GET(IOF)'=""

               WRITE @IOF

           if $GET(IOF)=""

               WRITE !

 +4        SET IBA=$EXTRACT(IBSPACES,1,(4-$LENGTH(IBPGC)))_IBPGC

           SET IBLNC=4

 +5        WRITE HDRNAME,?40,HDRDATE,?69,"Page: ",IBA,!

 +6        IF IBPGC=1

               Begin DoDot:1

 +7                SET IBLNC=5

                   SET IBF="Filters: "_$SELECT(IBCNOR("IBI")=1:"All",1:"Selected")_" Insurances, "

 +8                SET IBF=IBF_$SELECT(IBCNOR("IBIG")=1:"All",1:"Selected")_" Group Plans"

 +9                SET IBG="NAME Between "_$SELECT(IBRF="":"'FIRST'",1:IBRF)_" and "_$SELECT(IBRL="zzzzzz":"'LAST'",1:IBRL)

 +10               WRITE IBF

 +11               IF ($LENGTH(IBF)+($LENGTH(IBG)+2)>80)

                       WRITE !

                       SET IBLNC=6

 +12              IF '$TEST

                       WRITE ", "

 +13               WRITE IBG,!

               End DoDot:1

 +14       WRITE !,"Patient Name",?32,"DOB",?48,"SSN"

 +15       WRITE !,$EXTRACT(IBDASHES,1,79)

 +16       QUIT 

 +17      ;

EXIT      ; leave option

 +1       ;

 +2        KILL ^TMP($JOB)

 +3        KILL @IBTMP

 +4        KILL ^TMP(IBJOB,"IBCNOR")

 +5       ;

 +6        QUIT 

 +7       ;

QLINE     ; cr to continue

 +1       ;

 +2        NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LIN

 +3        IF MAXCNT<51&('IBEORM)

               FOR LIN=1:1:(IBXTFEED-IBLNC)

                   WRITE !

 +4        IF 'CRT

               QUIT 

 +5        SET DIR(0)="E"

           DO ^DIR

           KILL DIR

 +6        IF $DATA(DTOUT)!$DATA(DUOUT)

               SET IBSTOP=1

 +7        QUIT 

 +8       ;

DTC(IBDTCK) ; check date return external if valid

 +1       ;

 +2        NEW IBDT,IBBK

           SET IBDT=""

 +3        IF 'IBDTCK

               GOTO DTCO

 +4        SET IBBK=$$VALIDDT^IBCNINSU($PIECE(IBDTCK,".",1))

 +5        IF IBBK="-1"!(IBBK="")

               GOTO DTCO

 +6        SET IBDT=$$FMTE^XLFDT(IBBK,"5DZ")

 +7        IF IBDT="00/00/00"

               SET IBDT=""

 +8        GOTO DTCO

 +9       ;

DTCO      ; date check exit

 +1       ;

 +2        QUIT IBDT

 +3       ;

BLDPT     ; collect the subscribers for the policies/groups

 +1       ;

 +2        NEW IBA,IBAR35,IBC,IBCT,IBDTH,IBF,IBFC,IBGC,IB3553,IB36,IBIN,IBPNM,IBPNMA,IBPTDFN,IBPTINS

 +3       ;

 +4       ; clear found patients

 +5        KILL ^TMP("IBCNOR",$JOB,"P-PT")

 +6        SET IBC=0

           SET IBF=0

           SET IBCT=0

           SET IBFC=0

 +7        FOR 

               SET IBC=$ORDER(^TMP("IBCNOR",$JOB,"INS",IBC))

               if 'IBC

                   QUIT 

               SET IB36=$GET(^TMP("IBCNOR",$JOB,"INS",IBC))

               IF IB36

                   Begin DoDot:1

 +8                    SET IBGC=0

                       KILL IBAR35

 +9                    FOR 

                           SET IBGC=$ORDER(^TMP("IBCNOR",$JOB,"INS",IBC,"GRP",IBGC))

                           if 'IBGC

                               QUIT 

                           Begin DoDot:2

 +10                           SET IB3553=$GET(^TMP("IBCNOR",$JOB,"INS",IBC,"GRP",IBGC))

                               IF IB3553

                                   SET IBAR35(IB3553)=1

                           End DoDot:2

 +11      ; walk patient file for found combos.

 +12                   SET IBPTDFN=0

                       SET IBF=0

                       FOR 

                           SET IBPTDFN=$ORDER(^DPT("AB",IB36,IBPTDFN))

                           if 'IBPTDFN

                               QUIT 

                           SET IBPTINS=0

                           Begin DoDot:2

 +13      ;

 +14      ; only put pt in list once

                               IF $GET(^TMP("IBCNOR",$JOB,"P-PT",IBPTDFN))'=""

                                   QUIT 

 +15      ;

 +16      ; only look at living patients

                               SET IBDTH=""

                               SET IBDTH=$$GET1^DIQ(2,IBPTDFN_",",.351)

                               IF IBDTH'=""

                                   QUIT