IBCNSJ53 ;AITC/DTG - INSURANCE PLAN MAINTENANCE ACTION VIEW SUBSCRIBER ; 15-MAY-2023
;;2.0;INTEGRATED BILLING;**763,771,778**;21-MAR-94;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;
;
VP ; -- Edit/View Plan (VS entry point)
D FULL^VALM1
D EN^VALM("IBCNSC PLAN VIEW SUBSCRIBERS")
S VALMBCK="R",VALMBG=1
Q
;
VSUBS ; entry from list template protocol 'IBCNSJ PLAN VIEW SUBSCRIBERS' from the 'IBCNSC PLAN DETAIL' menu
;
N DIR,FIEN,FTF,FTFV,IBA,IBB,IBC,IBD,IBDOB,IBDTCK,IBE,IBEFFDT,IBERR,IBEXPDT,IBF
N IBIND,IBINS0,IBNAM,IBPTDFN,IBPTHOLD,IBPTINS,NUM
N ST,X,XX,X0,X11,Y,Z
; clear working array
S IBTMP="^TMP(""IBCNSJ53I"",$J)"
K @IBTMP
S (IBCST,IBACCT,IBINACCT,LENEP,LENPT)=0
;set insurance CO. info
;
S X0=$G(^DIC(36,IB36,0))
S X11=$G(^DIC(36,IB36,.11))
S Z=$P(X11,"^",6)
S ST=$S($P(X11,"^",5):$P($G(^DIC(5,$P(X11,"^",5),0)),"^",2),1:"")
S XX=$S($P(X0,"^",5):"*",1:"")
S X=XX_$E($P(X0,"^",1),1,30)
S $P(X,"^",2)=$P(X11,"^",1)
S $P(X,"^",3)=$P(X11,"^",4) S:$P(X,U,3)'="" $P(X,U,3)=$P(X,U,3)_","
S $P(X,"^",4)=$G(ST)
S $P(X,"^",5)=$E(Z,1,5)
S $P(X,"^",6)=""
S $P(X,U,7)=$P(X,U,3)_" "_$P(X,U,4)_" "_$P(X,U,5)
; Insurance Company name (first 30 chars) with leading '*' if inactive ^ Street Address Line 1
; ^ City ^ ST ^ ZIP ^
S @IBTMP@(1)=X
;set plan info
; A1 - Group Plan Number (leading '*' if Inactive)
; A2 - Group Plan Name (leading '+' if Individual)
; A3 -
; A4 - Electronic Plan Type (max length 26)
; A5 - Type of Plan (max length 34)
;
N IBFL1,IBFL2,NAME,NUM,XX,ZZ
S NUM=$$GET1^DIQ(355.3,IB3553,2.02)
S:NUM="" NUM="<NO GROUP NUMBER>"
S XX=$$GET1^DIQ(355.3,IB3553,.02,"I") ; Group or Individual Plan
S IBFL1=$S(XX=1:"",1:"+")
S ZZ=$$GET1^DIQ(355.3,IB3553,.11,"I") ; Inactive Flag
S IBFL2=$S(ZZ=1:"*",1:"")
S $P(XX,"^",1)=IBFL2_NUM ; Add Inactive/Individual flags
S NAME=$$GET1^DIQ(355.3,IB3553,2.01)
S:NAME="" NAME="<NO GROUP NAME>"
S $P(XX,"^",2)=IBFL1_NAME ; Group Name
S $P(XX,"^",3)=""
S ZZ=$$GET1^DIQ(355.3,IB3553_",",.15) ; Electronic Plan Type
S:$L(ZZ)>$G(LENEP) LENEP=$L(ZZ) ; Maximum Electronic Plan length
S $P(XX,"^",4)=ZZ
S ZZ=$$GET1^DIQ(355.3,IB3553_",",.09) ; Type of Plan
S:$L(ZZ)>34 ZZ=$E(ZZ,1,34)
S:$L(ZZ)>$G(LENEP) LENEP=$L(ZZ) ; Maximum Plan Type length
S $P(XX,"^",5)=ZZ
; plan info
S @IBTMP@(2)=XX
S IBINS0=$G(^IBA(355.3,+IB3553,0))
; get plan subscribers
F IBA=3,4,5 K @IBTMP@(IBA)
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 IBA=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",.18,"I") I IBA=IB3553 D
...S IBIND=$$ZND^IBCNS1(IBPTDFN,IBPTINS)
...S IBCST=IBCST+1
...S X=$$PT^IBEFUNC(IBPTDFN)
...S IBNAM=$E($P(X,"^",1),1,22) ; Patient's Name (22 chars)
...S:IBNAM="" IBNAM="<Pt. "_IBPTDFN_" Name Missing>"
...S IBPTHOLD=IBNAM
...; Retrieve last 4 of SSN (last 5 if pseudo SSN)
...S XX=$$GET1^DIQ(2,IBPTDFN_",",.09,"I") ; Patient's SSN
...S XX=$S($E(XX,$L(XX))="P":$E(XX,$L(XX)-4,$L(XX)),1:$E(XX,$L(XX)-3,$L(XX)))
...S $P(IBPTHOLD,"^",2)=XX
...S IBDOB=$$GET1^DIQ(2,IBPTDFN_",",.03,"I"),XX=$$DTC(IBDOB) ; Patient's DOB
...S $P(IBPTHOLD,"^",3)=XX
...S XX=$P(IBIND,"^",2),XX=$S(XX'="":XX,1:"<NO SUBS ID>")
...S $P(IBPTHOLD,"^",4)=XX ; Subscriber ID (20 chars max)
...S IBEFFDT=$P(IBIND,"^",8),XX=$$DTC(IBEFFDT) ; Effective Date
...S $P(IBPTHOLD,"^",5)=XX
...S IBEXPDT=$P(IBIND,"^",4),XX=$$DTC(IBEXPDT) ; Expiration Date
...S $P(IBPTHOLD,"^",6)=XX
...; Whose Insurance?
...S XX=$P(IBIND,"^",6),XX=$S(XX="v":"VET",XX="s":"SPO",XX="o":"OTH",1:"UNK")
...S $P(IBPTHOLD,"^",7)=XX
...S XX=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",5.01,"I") ; Patient ID
...S $P(IBPTHOLD,"^",8)=XX
...; IB*778/DTG removed code for unused variable LENPID
...;active or inactive
...S (IBACT,IBINACT)=0 D S $P(IBPTHOLD,U,9)=IBACT,$P(IBPTHOLD,U,10)=IBINACT
....;
....I 'IBEFFDT!($P(IBPTHOLD,U,5)="") S IBINACT=1 Q ; if not a valid effective date count inactive
....;
....I (IBEXPDT'=""&($P(IBPTHOLD,U,6)'="")) D Q ; if there is a valid expiration date
.....;
.....I IBEXPDT<DT S IBINACT=1 Q ; if the expiration date is less than today count inactive
.....;
.....S IBACT=1 ; otherwise count active
....;
....I (IBEFFDT&($P(IBPTHOLD,U,5)'="")&(IBEFFDT>DT)) S IBINACT=1 Q ; if a valid effective date and the date is greater than today count inactive
....;
....S IBACT=1 ; otherwise count active
....;
...S IBACCT=IBACCT+IBACT,IBINACCT=IBINACCT+IBINACT
...;
...;end active or inactive
...;
...; 3=ALL, 4=ACTIVE, 5=INACTIVE
...; Patient's Name (22 chars) ^ Patient's SSN ^ Patient's DOB ^ Subscriber ID (20 chars max)
...; ^ Effective Date ^ Expiration Date ^ Whose Insurance? ^ Patient ID ^ ACTIVE ^ INACTIVE
...S @IBTMP@(3,IB3553,IBNAM_"@@"_IBPTDFN_"@@"_IBPTINS)=IBPTHOLD
...S @IBTMP@(($S(IBACT=1:4,1:5)),IB3553,IBNAM_"@@"_IBPTDFN_"@@"_IBPTINS)=IBPTHOLD
...; total ^ active ^ inactive
...S @IBTMP@(0)=+IBCST_U_+IBACCT_U_+IBINACCT
;
VSUBX ; quit back
;
Q
DTC(IBDTCK) ; check date return external if valid
;
N IBDT,IBBK S IBDT=""
I 'IBDTCK G DTCO
S IBDT=$$FMTE^XLFDT(IBDTCK,"2DZ")
;
G DTCO
;
DTCO ; date check exit
;
Q IBDT
;
EXIT ; -- exit code
K VALMBCK,^TMP("IBCNSJ53",$J),^TMP("IBCNSJ53I",$J),IBVPCLBG,IBVPCLEN
D CLEAN^VALM10,CLEAR^VALM1
S VALMBCK="R",VALMBG=1
Q
;
HELP ; -- help code
;
I $G(VALMANS)="??" S X="?" D DISP^XQORM1 W !! Q
D FULL^VALM1
N DIR,X,Y
W !
W !," Enter AC to only see active subscribers."
W !," Enter IN to only see inactive subscribers."
W !," Enter VA to see all subscribers.",!
S DIR(0)="E",DIR("A")="Press <Enter> to return to View Subscribers"
D ^DIR
K DIR,X,Y
S VALMBCK="R"
Q
;
INIT ; -- Load the plan detail segments
;
K ^TMP("IBCNSJ53",$J)
S VALMBG=1,(IBLCNT,VALMCNT)=0
S IB36=+$G(IBCNS),IB3553=+$G(IBCPOL)
S IBTMP="^TMP(""IBCNSJ53I"",$J)",(IBCST,IBACCT,IBINACCT,LENEP,LENPT)=0
K @IBTMP
D NOW^%DTC
S IBHDT=$$DAT2^IBOUTL($E(%,1,12))
S IBSPACE="",$P(IBSPACE," ",80)=""
I IB36<1!(IB3553<1) D Q
. W !!,*7,"Missing Insurance or Plan IEN."
;
D KILL^VALM10()
;
D VSUBS
;
D BVA
S VALMBCK="R",VALMBG=1
Q
;
ACINI ; active subscribers
;
D FULL^VALM1
D HDR("Active")
D AC
S VALMBCK="R",VALMBG=1
Q
;
ININI ; inactive subscribers
;
D FULL^VALM1
D HDR("Inactive")
D IS
S VALMBCK="R",VALMBG=1
Q
;
ALLINI ; all subscribers
;
D FULL^VALM1
D HDR("All")
D BVA
S VALMBCK="R",VALMBG=1
Q
;
HDR(IBDIS) ; -- Plan Subscribers
;
N IBA,IBB,IBC,IBD,IBE,IBF1,IBF2,IBL,IB1,IB2,IB3
S (IB1,IB2,IB3)=""
S IBA=$G(^TMP("IBCNSJ53I",$J,1)),IBB=$G(^TMP("IBCNSJ53I",$J,2)),IBC=$G(^TMP("IBCNSJ53I",$J,0))
S IBF2=$E($P(IBB,U,2))
S IBF1=$E($P(IBB,U,1))
S IBDIS=$G(IBDIS),IBDIS=$S(IBDIS'="":IBDIS,1:"All")
S VALM("TITLE")=IBDIS_" Subscribers"
;
S IB1=$E($P(IBA,U,1),1,30) ; ins co name
S IBL=(30-$L(IB1))+30,IB2=$E(IBSPACE,1,IBL)
S IB3="TOTAL SUB: "_($E(IBSPACE,1,(8-($L(+$P(IBC,U,1))))))_(+$P(IBC,U,1))
S VALMHDR(1)=IB1_IB2_IB3
;
S IB1=$E($P(IBA,U,2),1,35) ; ins addr
S IBE=$E($P(IBB,U,2),1,(21+($S(IBF2="+":1,1:0))))
S IBL=(35-$L(IB1))+(1+($S(IBF2="+":0,1:1)))
S IB2=$E(IBSPACE,1,IBL)_IBE ; group name
S IBL=(($S(IBF2="+":22,1:21))-$L(IBE))+1
S IB3=$E(IBSPACE,1,IBL)_"ACTIVE SUB: "_($E(IBSPACE,1,(8-($L(+$P(IBC,U,2))))))_(+$P(IBC,U,2))
S VALMHDR(2)=IB1_IB2_IB3
;
S IB1=$E($P(IBA,U,7),1,35) ; city, state zip
S IBE=$E($P(IBB,U,1),1,(19+($S(IBF1="*":1,1:0))))
S IBL=(35-($L(IB1))+(1+($S(IBF1="*":0,1:1))))
S IB2=$E(IBSPACE,1,IBL)_IBE ; group number
S IBL=(($S(IBF1="*":20,1:19))-$L(IBE))+1
S IB3=$E(IBSPACE,1,IBL)_"INACTIVE SUB: "_($E(IBSPACE,1,(8-($L(+$P(IBC,U,3))))))_(+$P(IBC,U,3))
S VALMHDR(3)=IB1_IB2_IB3
;
Q
;
BVA ; Build ALL subscribers
;
N IBLINE,IBTMP1,IBF
S IBTMP1="^TMP(""IBCNSJ53I"",$J,3,"_IB3553_")"
S VALMCNT=0,VALMBG=1,IBLINE=0
K @VALMAR
S IBF=$G(^TMP("IBCNSJ53I",$J,0))
I '+IBF D Q ; IB*771/DTG put none found back in display
. S VALMCNT=2,@VALMAR@(1,0)=" "
. S @VALMAR@(2,0)=" ***Group Contains No Subscribers***"
; go through the 3 level
D BPAS
Q
;
BPAS ; build items from base into valm display
;
N IBA,IBB,IBC,IBD,IBE,IBNM,IBDFN,IBNODE,X
S IBA="",X="" F S IBA=$O(@IBTMP1@(IBA)) Q:IBA="" D
. S IBNM=$P(IBA,"@@",1),IBDFN=$P(IBA,"@@",2),IBNODE=$P(IBA,"@@",3)
. S VALMCNT=VALMCNT+1,IBC=@IBTMP1@(IBA),X="",IBLINE=IBLINE+1
. S X=$$SETFLD^VALM1($P(IBC,"^",1),X,"SNAME")
. S X=$$SETFLD^VALM1($P(IBC,"^",2),X,"SSN4")
. S X=$$SETFLD^VALM1($P(IBC,U,3),X,"DOB10")
. S X=$$SETFLD^VALM1($P(IBC,"^",4),X,"SUBID")
. S X=$$SETFLD^VALM1($P(IBC,U,5),X,"EFFDT")
. S X=$$SETFLD^VALM1($P(IBC,U,6),X,"EXPDT")
. S X=$$SETFLD^VALM1($P(IBC,"^",7),X,"WHO")
. S X=$$SETFLD^VALM1($P(IBC,"^",8),X,"PATID")
. S IBD=$P(IBC,U,9),X=$$SETFLD^VALM1($S(IBD=1:"Y",1:""),X,"ACT")
. S @VALMAR@(VALMCNT,0)=X
Q
;
AC ; active subscriber entry
;
N IBLINE,IBTMP1,IBF
S IBTMP1="^TMP(""IBCNSJ53I"",$J,4,"_IB3553_")"
S VALMCNT=0,VALMBG=1,IBLINE=0
K @VALMAR
S IBF=$G(^TMP("IBCNSJ53I",$J,0))
I '+$P(IBF,U,2) D Q
. S VALMCNT=2,@VALMAR@(1,0)=" "
. S @VALMAR@(2,0)=" ***Group Contains No Active Subscribers***"
; go through the 4 level
D BPAS
Q
;
IS ; inactive subscriber entry
;
N IBLINE,IBTMP1,IBF
S IBTMP1="^TMP(""IBCNSJ53I"",$J,5,"_IB3553_")"
S VALMCNT=0,VALMBG=1,IBLINE=0
K @VALMAR
S IBF=$G(^TMP("IBCNSJ53I",$J,0))
I '+$P(IBF,U,3) D Q
. S VALMCNT=2,@VALMAR@(1,0)=" "
. S @VALMAR@(2,0)=" ***Group Contains No Inactive Subscribers***"
; go through the 5 level
D BPAS
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSJ53 9940 printed Dec 13, 2024@02:17:23 Page 2
IBCNSJ53 ;AITC/DTG - INSURANCE PLAN MAINTENANCE ACTION VIEW SUBSCRIBER ; 15-MAY-2023
+1 ;;2.0;INTEGRATED BILLING;**763,771,778**;21-MAR-94;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
VP ; -- Edit/View Plan (VS entry point)
+1 DO FULL^VALM1
+2 DO EN^VALM("IBCNSC PLAN VIEW SUBSCRIBERS")
+3 SET VALMBCK="R"
SET VALMBG=1
+4 QUIT
+5 ;
VSUBS ; entry from list template protocol 'IBCNSJ PLAN VIEW SUBSCRIBERS' from the 'IBCNSC PLAN DETAIL' menu
+1 ;
+2 NEW DIR,FIEN,FTF,FTFV,IBA,IBB,IBC,IBD,IBDOB,IBDTCK,IBE,IBEFFDT,IBERR,IBEXPDT,IBF
+3 NEW IBIND,IBINS0,IBNAM,IBPTDFN,IBPTHOLD,IBPTINS,NUM
+4 NEW ST,X,XX,X0,X11,Y,Z
+5 ; clear working array
+6 SET IBTMP="^TMP(""IBCNSJ53I"",$J)"
+7 KILL @IBTMP
+8 SET (IBCST,IBACCT,IBINACCT,LENEP,LENPT)=0
+9 ;set insurance CO. info
+10 ;
+11 SET X0=$GET(^DIC(36,IB36,0))
+12 SET X11=$GET(^DIC(36,IB36,.11))
+13 SET Z=$PIECE(X11,"^",6)
+14 SET ST=$SELECT($PIECE(X11,"^",5):$PIECE($GET(^DIC(5,$PIECE(X11,"^",5),0)),"^",2),1:"")
+15 SET XX=$SELECT($PIECE(X0,"^",5):"*",1:"")
+16 SET X=XX_$EXTRACT($PIECE(X0,"^",1),1,30)
+17 SET $PIECE(X,"^",2)=$PIECE(X11,"^",1)
+18 SET $PIECE(X,"^",3)=$PIECE(X11,"^",4)
if $PIECE(X,U,3)'=""
SET $PIECE(X,U,3)=$PIECE(X,U,3)_","
+19 SET $PIECE(X,"^",4)=$GET(ST)
+20 SET $PIECE(X,"^",5)=$EXTRACT(Z,1,5)
+21 SET $PIECE(X,"^",6)=""
+22 SET $PIECE(X,U,7)=$PIECE(X,U,3)_" "_$PIECE(X,U,4)_" "_$PIECE(X,U,5)
+23 ; Insurance Company name (first 30 chars) with leading '*' if inactive ^ Street Address Line 1
+24 ; ^ City ^ ST ^ ZIP ^
+25 SET @IBTMP@(1)=X
+26 ;set plan info
+27 ; A1 - Group Plan Number (leading '*' if Inactive)
+28 ; A2 - Group Plan Name (leading '+' if Individual)
+29 ; A3 -
+30 ; A4 - Electronic Plan Type (max length 26)
+31 ; A5 - Type of Plan (max length 34)
+32 ;
+33 NEW IBFL1,IBFL2,NAME,NUM,XX,ZZ
+34 SET NUM=$$GET1^DIQ(355.3,IB3553,2.02)
+35 if NUM=""
SET NUM="<NO GROUP NUMBER>"
+36 ; Group or Individual Plan
SET XX=$$GET1^DIQ(355.3,IB3553,.02,"I")
+37 SET IBFL1=$SELECT(XX=1:"",1:"+")
+38 ; Inactive Flag
SET ZZ=$$GET1^DIQ(355.3,IB3553,.11,"I")
+39 SET IBFL2=$SELECT(ZZ=1:"*",1:"")
+40 ; Add Inactive/Individual flags
SET $PIECE(XX,"^",1)=IBFL2_NUM
+41 SET NAME=$$GET1^DIQ(355.3,IB3553,2.01)
+42 if NAME=""
SET NAME="<NO GROUP NAME>"
+43 ; Group Name
SET $PIECE(XX,"^",2)=IBFL1_NAME
+44 SET $PIECE(XX,"^",3)=""
+45 ; Electronic Plan Type
SET ZZ=$$GET1^DIQ(355.3,IB3553_",",.15)
+46 ; Maximum Electronic Plan length
if $LENGTH(ZZ)>$GET(LENEP)
SET LENEP=$LENGTH(ZZ)
+47 SET $PIECE(XX,"^",4)=ZZ
+48 ; Type of Plan
SET ZZ=$$GET1^DIQ(355.3,IB3553_",",.09)
+49 if $LENGTH(ZZ)>34
SET ZZ=$EXTRACT(ZZ,1,34)
+50 ; Maximum Plan Type length
if $LENGTH(ZZ)>$GET(LENEP)
SET LENEP=$LENGTH(ZZ)
+51 SET $PIECE(XX,"^",5)=ZZ
+52 ; plan info
+53 SET @IBTMP@(2)=XX
+54 SET IBINS0=$GET(^IBA(355.3,+IB3553,0))
+55 ; get plan subscribers
+56 FOR IBA=3,4,5
KILL @IBTMP@(IBA)
+57 SET IBPTDFN=0
+58 FOR
SET IBPTDFN=$ORDER(^DPT("AB",IB36,IBPTDFN))
if 'IBPTDFN
QUIT
SET IBPTINS=0
Begin DoDot:1
+59 FOR
SET IBPTINS=$ORDER(^DPT("AB",IB36,IBPTDFN,IBPTINS))
if 'IBPTINS
QUIT
Begin DoDot:2
+60 SET IBA=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",.18,"I")
IF IBA=IB3553
Begin DoDot:3
+61 SET IBIND=$$ZND^IBCNS1(IBPTDFN,IBPTINS)
+62 SET IBCST=IBCST+1
+63 SET X=$$PT^IBEFUNC(IBPTDFN)
+64 ; Patient's Name (22 chars)
SET IBNAM=$EXTRACT($PIECE(X,"^",1),1,22)
+65 if IBNAM=""
SET IBNAM="<Pt. "_IBPTDFN_" Name Missing>"
+66 SET IBPTHOLD=IBNAM
+67 ; Retrieve last 4 of SSN (last 5 if pseudo SSN)
+68 ; Patient's SSN
SET XX=$$GET1^DIQ(2,IBPTDFN_",",.09,"I")
+69 SET XX=$SELECT($EXTRACT(XX,$LENGTH(XX))="P":$EXTRACT(XX,$LENGTH(XX)-4,$LENGTH(XX)),1:$EXTRACT(XX,$LENGTH(XX)-3,$LENGTH(XX)))
+70 SET $PIECE(IBPTHOLD,"^",2)=XX
+71 ; Patient's DOB
SET IBDOB=$$GET1^DIQ(2,IBPTDFN_",",.03,"I")
SET XX=$$DTC(IBDOB)
+72 SET $PIECE(IBPTHOLD,"^",3)=XX
+73 SET XX=$PIECE(IBIND,"^",2)
SET XX=$SELECT(XX'="":XX,1:"<NO SUBS ID>")
+74 ; Subscriber ID (20 chars max)
SET $PIECE(IBPTHOLD,"^",4)=XX
+75 ; Effective Date
SET IBEFFDT=$PIECE(IBIND,"^",8)
SET XX=$$DTC(IBEFFDT)
+76 SET $PIECE(IBPTHOLD,"^",5)=XX
+77 ; Expiration Date
SET IBEXPDT=$PIECE(IBIND,"^",4)
SET XX=$$DTC(IBEXPDT)
+78 SET $PIECE(IBPTHOLD,"^",6)=XX
+79 ; Whose Insurance?
+80 SET XX=$PIECE(IBIND,"^",6)
SET XX=$SELECT(XX="v":"VET",XX="s":"SPO",XX="o":"OTH",1:"UNK")
+81 SET $PIECE(IBPTHOLD,"^",7)=XX
+82 ; Patient ID
SET XX=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",5.01,"I")
+83 SET $PIECE(IBPTHOLD,"^",8)=XX
+84 ; IB*778/DTG removed code for unused variable LENPID
+85 ;active or inactive
+86 SET (IBACT,IBINACT)=0
Begin DoDot:4
+87 ;
+88 ; if not a valid effective date count inactive
IF 'IBEFFDT!($PIECE(IBPTHOLD,U,5)="")
SET IBINACT=1
QUIT
+89 ;
+90 ; if there is a valid expiration date
IF (IBEXPDT'=""&($PIECE(IBPTHOLD,U,6)'=""))
Begin DoDot:5
+91 ;
+92 ; if the expiration date is less than today count inactive
IF IBEXPDT<DT
SET IBINACT=1
QUIT
+93 ;
+94 ; otherwise count active
SET IBACT=1
End DoDot:5
QUIT
+95 ;
+96 ; if a valid effective date and the date is greater than today count inactive
IF (IBEFFDT&($PIECE(IBPTHOLD,U,5)'="")&(IBEFFDT>DT))
SET IBINACT=1
QUIT
+97 ;
+98 ; otherwise count active
SET IBACT=1
+99 ;
End DoDot:4
SET $PIECE(IBPTHOLD,U,9)=IBACT
SET $PIECE(IBPTHOLD,U,10)=IBINACT
+100 SET IBACCT=IBACCT+IBACT
SET IBINACCT=IBINACCT+IBINACT
+101 ;
+102 ;end active or inactive
+103 ;
+104 ; 3=ALL, 4=ACTIVE, 5=INACTIVE
+105 ; Patient's Name (22 chars) ^ Patient's SSN ^ Patient's DOB ^ Subscriber ID (20 chars max)
+106 ; ^ Effective Date ^ Expiration Date ^ Whose Insurance? ^ Patient ID ^ ACTIVE ^ INACTIVE
+107 SET @IBTMP@(3,IB3553,IBNAM_"@@"_IBPTDFN_"@@"_IBPTINS)=IBPTHOLD
+108 SET @IBTMP@(($SELECT(IBACT=1:4,1:5)),IB3553,IBNAM_"@@"_IBPTDFN_"@@"_IBPTINS)=IBPTHOLD
+109 ; total ^ active ^ inactive
+110 SET @IBTMP@(0)=+IBCST_U_+IBACCT_U_+IBINACCT
End DoDot:3
End DoDot:2
End DoDot:1
+111 ;
VSUBX ; quit back
+1 ;
+2 QUIT
DTC(IBDTCK) ; check date return external if valid
+1 ;
+2 NEW IBDT,IBBK
SET IBDT=""
+3 IF 'IBDTCK
GOTO DTCO
+4 SET IBDT=$$FMTE^XLFDT(IBDTCK,"2DZ")
+5 ;
+6 GOTO DTCO
+7 ;
DTCO ; date check exit
+1 ;
+2 QUIT IBDT
+3 ;
EXIT ; -- exit code
+1 KILL VALMBCK,^TMP("IBCNSJ53",$JOB),^TMP("IBCNSJ53I",$JOB),IBVPCLBG,IBVPCLEN
+2 DO CLEAN^VALM10
DO CLEAR^VALM1
+3 SET VALMBCK="R"
SET VALMBG=1
+4 QUIT
+5 ;
HELP ; -- help code
+1 ;
+2 IF $GET(VALMANS)="??"
SET X="?"
DO DISP^XQORM1
WRITE !!
QUIT
+3 DO FULL^VALM1
+4 NEW DIR,X,Y
+5 WRITE !
+6 WRITE !," Enter AC to only see active subscribers."
+7 WRITE !," Enter IN to only see inactive subscribers."
+8 WRITE !," Enter VA to see all subscribers.",!
+9 SET DIR(0)="E"
SET DIR("A")="Press <Enter> to return to View Subscribers"
+10 DO ^DIR
+11 KILL DIR,X,Y
+12 SET VALMBCK="R"
+13 QUIT
+14 ;
INIT ; -- Load the plan detail segments
+1 ;
+2 KILL ^TMP("IBCNSJ53",$JOB)
+3 SET VALMBG=1
SET (IBLCNT,VALMCNT)=0
+4 SET IB36=+$GET(IBCNS)
SET IB3553=+$GET(IBCPOL)
+5 SET IBTMP="^TMP(""IBCNSJ53I"",$J)"
SET (IBCST,IBACCT,IBINACCT,LENEP,LENPT)=0
+6 KILL @IBTMP
+7 DO NOW^%DTC
+8 SET IBHDT=$$DAT2^IBOUTL($EXTRACT(%,1,12))
+9 SET IBSPACE=""
SET $PIECE(IBSPACE," ",80)=""
+10 IF IB36<1!(IB3553<1)
Begin DoDot:1
+11 WRITE !!,*7,"Missing Insurance or Plan IEN."
End DoDot:1
QUIT
+12 ;
+13 DO KILL^VALM10()
+14 ;
+15 DO VSUBS
+16 ;
+17 DO BVA
+18 SET VALMBCK="R"
SET VALMBG=1
+19 QUIT
+20 ;
ACINI ; active subscribers
+1 ;
+2 DO FULL^VALM1
+3 DO HDR("Active")
+4 DO AC
+5 SET VALMBCK="R"
SET VALMBG=1
+6 QUIT
+7 ;
ININI ; inactive subscribers
+1 ;
+2 DO FULL^VALM1
+3 DO HDR("Inactive")
+4 DO IS
+5 SET VALMBCK="R"
SET VALMBG=1
+6 QUIT
+7 ;
ALLINI ; all subscribers
+1 ;
+2 DO FULL^VALM1
+3 DO HDR("All")
+4 DO BVA
+5 SET VALMBCK="R"
SET VALMBG=1
+6 QUIT
+7 ;
HDR(IBDIS) ; -- Plan Subscribers
+1 ;
+2 NEW IBA,IBB,IBC,IBD,IBE,IBF1,IBF2,IBL,IB1,IB2,IB3
+3 SET (IB1,IB2,IB3)=""
+4 SET IBA=$GET(^TMP("IBCNSJ53I",$JOB,1))
SET IBB=$GET(^TMP("IBCNSJ53I",$JOB,2))
SET IBC=$GET(^TMP("IBCNSJ53I",$JOB,0))
+5 SET IBF2=$EXTRACT($PIECE(IBB,U,2))
+6 SET IBF1=$EXTRACT($PIECE(IBB,U,1))
+7 SET IBDIS=$GET(IBDIS)
SET IBDIS=$SELECT(IBDIS'="":IBDIS,1:"All")
+8 SET VALM("TITLE")=IBDIS_" Subscribers"
+9 ;
+10 ; ins co name
SET IB1=$EXTRACT($PIECE(IBA,U,1),1,30)
+11 SET IBL=(30-$LENGTH(IB1))+30
SET IB2=$EXTRACT(IBSPACE,1,IBL)
+12 SET IB3="TOTAL SUB: "_($EXTRACT(IBSPACE,1,(8-($LENGTH(+$PIECE(IBC,U,1))))))_(+$PIECE(IBC,U,1))
+13 SET VALMHDR(1)=IB1_IB2_IB3
+14 ;
+15 ; ins addr
SET IB1=$EXTRACT($PIECE(IBA,U,2),1,35)
+16 SET IBE=$EXTRACT($PIECE(IBB,U,2),1,(21+($SELECT(IBF2="+":1,1:0))))
+17 SET IBL=(35-$LENGTH(IB1))+(1+($SELECT(IBF2="+":0,1:1)))
+18 ; group name
SET IB2=$EXTRACT(IBSPACE,1,IBL)_IBE
+19 SET IBL=(($SELECT(IBF2="+":22,1:21))-$LENGTH(IBE))+1
+20 SET IB3=$EXTRACT(IBSPACE,1,IBL)_"ACTIVE SUB: "_($EXTRACT(IBSPACE,1,(8-($LENGTH(+$PIECE(IBC,U,2))))))_(+$PIECE(IBC,U,2))
+21 SET VALMHDR(2)=IB1_IB2_IB3
+22 ;
+23 ; city, state zip
SET IB1=$EXTRACT($PIECE(IBA,U,7),1,35)
+24 SET IBE=$EXTRACT($PIECE(IBB,U,1),1,(19+($SELECT(IBF1="*":1,1:0))))
+25 SET IBL=(35-($LENGTH(IB1))+(1+($SELECT(IBF1="*":0,1:1))))
+26 ; group number
SET IB2=$EXTRACT(IBSPACE,1,IBL)_IBE
+27 SET IBL=(($SELECT(IBF1="*":20,1:19))-$LENGTH(IBE))+1
+28 SET IB3=$EXTRACT(IBSPACE,1,IBL)_"INACTIVE SUB: "_($EXTRACT(IBSPACE,1,(8-($LENGTH(+$PIECE(IBC,U,3))))))_(+$PIECE(IBC,U,3))
+29 SET VALMHDR(3)=IB1_IB2_IB3
+30 ;
+31 QUIT
+32 ;
BVA ; Build ALL subscribers
+1 ;
+2 NEW IBLINE,IBTMP1,IBF
+3 SET IBTMP1="^TMP(""IBCNSJ53I"",$J,3,"_IB3553_")"
+4 SET VALMCNT=0
SET VALMBG=1
SET IBLINE=0
+5 KILL @VALMAR
+6 SET IBF=$GET(^TMP("IBCNSJ53I",$JOB,0))
+7 ; IB*771/DTG put none found back in display
IF '+IBF
Begin DoDot:1
+8 SET VALMCNT=2
SET @VALMAR@(1,0)=" "
+9 SET @VALMAR@(2,0)=" ***Group Contains No Subscribers***"
End DoDot:1
QUIT
+10 ; go through the 3 level
+11 DO BPAS
+12 QUIT
+13 ;
BPAS ; build items from base into valm display
+1 ;
+2 NEW IBA,IBB,IBC,IBD,IBE,IBNM,IBDFN,IBNODE,X
+3 SET IBA=""
SET X=""
FOR
SET IBA=$ORDER(@IBTMP1@(IBA))
if IBA=""
QUIT
Begin DoDot:1
+4 SET IBNM=$PIECE(IBA,"@@",1)
SET IBDFN=$PIECE(IBA,"@@",2)
SET IBNODE=$PIECE(IBA,"@@",3)
+5 SET VALMCNT=VALMCNT+1
SET IBC=@IBTMP1@(IBA)
SET X=""
SET IBLINE=IBLINE+1
+6 SET X=$$SETFLD^VALM1($PIECE(IBC,"^",1),X,"SNAME")
+7 SET X=$$SETFLD^VALM1($PIECE(IBC,"^",2),X,"SSN4")
+8 SET X=$$SETFLD^VALM1($PIECE(IBC,U,3),X,"DOB10")
+9 SET X=$$SETFLD^VALM1($PIECE(IBC,"^",4),X,"SUBID")
+10 SET X=$$SETFLD^VALM1($PIECE(IBC,U,5),X,"EFFDT")
+11 SET X=$$SETFLD^VALM1($PIECE(IBC,U,6),X,"EXPDT")
+12 SET X=$$SETFLD^VALM1($PIECE(IBC,"^",7),X,"WHO")
+13 SET X=$$SETFLD^VALM1($PIECE(IBC,"^",8),X,"PATID")
+14 SET IBD=$PIECE(IBC,U,9)
SET X=$$SETFLD^VALM1($SELECT(IBD=1:"Y",1:""),X,"ACT")
+15 SET @VALMAR@(VALMCNT,0)=X
End DoDot:1
+16 QUIT
+17 ;
AC ; active subscriber entry
+1 ;
+2 NEW IBLINE,IBTMP1,IBF
+3 SET IBTMP1="^TMP(""IBCNSJ53I"",$J,4,"_IB3553_")"
+4 SET VALMCNT=0
SET VALMBG=1
SET IBLINE=0
+5 KILL @VALMAR
+6 SET IBF=$GET(^TMP("IBCNSJ53I",$JOB,0))
+7 IF '+$PIECE(IBF,U,2)
Begin DoDot:1
+8 SET VALMCNT=2
SET @VALMAR@(1,0)=" "
+9 SET @VALMAR@(2,0)=" ***Group Contains No Active Subscribers***"
End DoDot:1
QUIT
+10 ; go through the 4 level
+11 DO BPAS
+12 QUIT
+13 ;
IS ; inactive subscriber entry
+1 ;
+2 NEW IBLINE,IBTMP1,IBF
+3 SET IBTMP1="^TMP(""IBCNSJ53I"",$J,5,"_IB3553_")"
+4 SET VALMCNT=0
SET VALMBG=1
SET IBLINE=0
+5 KILL @VALMAR
+6 SET IBF=$GET(^TMP("IBCNSJ53I",$JOB,0))
+7 IF '+$PIECE(IBF,U,3)
Begin DoDot:1
+8 SET VALMCNT=2
SET @VALMAR@(1,0)=" "
+9 SET @VALMAR@(2,0)=" ***Group Contains No Inactive Subscribers***"
End DoDot:1
QUIT
+10 ; go through the 5 level
+11 DO BPAS
+12 QUIT
+13 ;
