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 ---[H[J[2J[HIBCNOR1A 9293 printed Apr 09, 2024@21:35:51 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
+17 SET IBPNM=$$GET1^DIQ(2,IBPTDFN_",",.01,"E")
SET IBPNMA=$$UP^XLFSTR(IBPNM)
+18 FOR
SET IBPTINS=$ORDER(^DPT("AB",IB36,IBPTDFN,IBPTINS))
if 'IBPTINS
QUIT
Begin DoDot:3
+19 SET IBCT=IBCT+1
IF $GET(IOST)["C-"
if IBCT#2000=0
WRITE "."
+20 SET IBA=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",.18,"I")
IF IBA
Begin DoDot:4
+21 IF $GET(IBAR35(IBA))'=1
QUIT
+22 ; only put pt in list once
IF $GET(^TMP("IBCNOR",$JOB,"P-PT",IBPTDFN))'=""
QUIT
+23 IF $EXTRACT(IBPNM,1,$LENGTH(IBRLU))]IBRLU
QUIT
+24 IF IBRFU]$EXTRACT(IBPNM,1,$LENGTH(IBRFU))
QUIT
+25 ; NM from DPT ^ ins ien ^ group ien ^ NM uppercase
+26 SET ^TMP("IBCNOR",$JOB,"P-PT",IBPTDFN)=IBPNM_U_IB36_U_IB3553_U_IBPNMA
SET IBF=1
+27 SET IBFC=$GET(^TMP("IBCNOR",$JOB,"P-PT",0))+1
SET ^TMP("IBCNOR",$JOB,"P-PT",0)=IBFC
End DoDot:4
End DoDot:3
if IBF
QUIT
End DoDot:2
End DoDot:1
+28 SET $PIECE(^TMP("IBCNOR",$JOB,"P-PT",0),U,2)=+$GET(IBCT)
+29 QUIT
+30 ;
