IBCNSJ53 ;AITC/DTG - INSURANCE PLAN MAINTENANCE ACTION VIEW SUBSCRIBER ; 15-MAY-2023
;;2.0;INTEGRATED BILLING;**763,771,778,804**;21-MAR-94;Build 6
;;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
;IB*804/DTG add sort to view subscribers
;F IBA=3,4,5 K @IBTMP@(IBA)
F IBA=3,4,5,9,10,11 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=$$DTC5(IBDOB),$P(IBPTHOLD,"^",12)=XX ;IB*804/DTG add in the 5 digit date for sort
...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 XX=$$DTC5(IBEFFDT),$P(IBPTHOLD,"^",13)=XX ;IB*804/DTG add in the 5 digit date for sort
...S IBEXPDT=$P(IBIND,"^",4),XX=$$DTC(IBEXPDT) ; Expiration Date
...S $P(IBPTHOLD,"^",6)=XX
...S XX=$$DTC5(IBEXPDT),$P(IBPTHOLD,"^",14)=XX ;IB*804/DTG add in the 5 digit date for sort
...; 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 ^^ 4 digit DOB year
...; ^ 4 digit eff dt year ^ 4 digit exp dt year
...; IB*804/DTG add sort to view subscribers
...;S @IBTMP@(3,IB3553,IBNAM_"@@"_IBPTDFN_"@@"_IBPTINS)=IBPTHOLD
...;S @IBTMP@(($S(IBACT=1:4,1:5)),IB3553,IBNAM_"@@"_IBPTDFN_"@@"_IBPTINS)=IBPTHOLD
...S @IBTMP@(9,IB3553,IBNAM_"@@"_IBPTDFN_"@@"_IBPTINS)=IBPTHOLD
...S @IBTMP@(($S(IBACT=1:10,1:11)),IB3553,IBNAM_"@@"_IBPTDFN_"@@"_IBPTINS)=IBPTHOLD
...; total ^ active ^ inactive
...S @IBTMP@(0)=+IBCST_U_+IBACCT_U_+IBINACCT
;
;IB*804/DTG add sort to view subscribers
; base set of values
D IBASE
;
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
;
DTC5(IBDTCK) ; check date return external if valid ;IB*804/DTG 4 digit year for sort's
;
N IBDT,IBBK S IBDT=""
I 'IBDTCK G DTCO
S IBDT=$$FMTE^XLFDT(IBDTCK,"5DZ")
;
G DTC5O
;
DTC5O ; 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."
; IB*804/DTG add sort to view subscribers
;W !," Enter VA to see all subscribers.",!
W !," Enter VA to see all subscribers."
W !," Enter ST to sort the subscriber records",!
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
S (IBOSRT,IBSORTA)=0,IBSACT=3 ;IB*804/DTG add sort to view subscribers. default sort type is all
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
;
S IBSORTA="",IBSACT=4 D IBASE ; IB*804/DTG VS sort
D FULL^VALM1
D HDR("Active")
D AC
S VALMBCK="R",VALMBG=1
Q
;
ININI ; inactive subscribers
;
S IBSORTA="",IBSACT=5 D IBASE ; IB*804/DTG VS sort
D FULL^VALM1
D HDR("Inactive")
D IS
S VALMBCK="R",VALMBG=1
Q
;
ALLINI ; all subscribers
;
S IBSORTA="",IBSACT=3 D IBASE ; IB*804/DTG VS sort
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
; IB*804/DTG include sorts in view subscriber
N IB5,IBLA S (IB5,IBLA)=""
I '$G(IBSORTA) S IB5="Sort by: NAME" ;IB*804/DTG added in for sort type if none chosen
I $G(IBSORTA) S IB5="Sort by: "_$S(IBSORTA=1:"NAME",IBSORTA=2:"DOB",IBSORTA=3:"EFF DATE",IBSORTA=4:"EXP DATE",1:"")
;S IBL=(30-$L(IB1))+30,IB2=$E(IBSPACE,1,IBL)
S IBL=(35-$L(IB1)),IBLA=(25-$L(IB5)),IB2=$E(IBSPACE,1,IBL)_IB5_$E(IBSPACE,1,IBLA)
;
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
;IB*804/DTG chage array for sort
;S IBTMP1="^TMP(""IBCNSJ53I"",$J,3,"_IB3553_")"
S IBTMP1="^TMP(""IBCNSJ53I"",$J,3)"
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
; IB*804/DTG include sorts in view subscriber Change from a single dot '.' level to three dot '.' levels
;S IBA="",X="" F S IBA=$O(@IBTMP1@(IBA)) Q:IBA="" D
N IBCNTR,IBG
S IBCNTR="" F S IBCNTR=$O(@IBTMP1@(IBCNTR)) Q:IBCNTR="" S IBG="" D
. F S IBG=$O(@IBTMP1@(IBCNTR,IBG)) Q:IBG="" S IBA="",X="" D
.. F S IBA=$O(@IBTMP1@(IBCNTR,IBG,IBA)) Q:IBA="" D
... S IBNM=$P(IBA,"@@",1),IBDFN=$P(IBA,"@@",2),IBNODE=$P(IBA,"@@",3)
... S VALMCNT=VALMCNT+1,IBC=@IBTMP1@(IBCNTR,IBG,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
;IB*804/DTG chage array for sort
;S IBTMP1="^TMP(""IBCNSJ53I"",$J,4,"_IB3553_")"
S IBTMP1="^TMP(""IBCNSJ53I"",$J,4)"
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
;IB*804/DTG chage array for sort
;S IBTMP1="^TMP(""IBCNSJ53I"",$J,5,"_IB3553_")"
S IBTMP1="^TMP(""IBCNSJ53I"",$J,5)"
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
;
;IB*804/DTG new for sort SORT - IBASE
SORT ; ask sort questions if sort selected then re-build ^TMP("IBCNSJ53I",$J,
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,IBJ,IBQUIT,IBSRF,IBSRNM,IBWORK,X,Y
S IBQUIT=0
D FULL^VALM1
S IBSACT=$G(IBSACT) I IBSACT<3 S IBSACT=3
S IBOSRT=IBSORTA
K DIR S DIR(0)="S^1:Subscriber Name;2:Date of Birth;3:Effective Date;4:Expiration Date"
S DIR("A")="SELECT 1, 2, 3, or 4"
S DIR("?")="Select a sort method or Enter '^' to quit"
S DIR("B")=$S(IBOSRT=2:"Date of Birth",IBOSRT=3:"Effective Date",IBOSRT=4:"Expiration Date",1:"Subscriber Name")
D ^DIR
I $E(Y)=U!$D(DIROUT)!$D(DIRUT)!$D(DTOUT)!$D(DUOUT) S Y="^"
I $E(Y)=U S IBQUIT=1 G SORTQ
S IBSORTA=+Y I Y<1 S IBQUIT=1 G SORTQ
I IBSORTA=1 D IBSRTNM G SORTQ
S IBJ=$S(IBSORTA=2:"Date of Birth",IBSORTA=3:"Effective Date",IBSORTA=4:"Expiration Date",1:"")
I IBJ="" S IBQUIT=1 G SORTQ
S Y=$$IBSRQU(IBJ,"",0)
I $E(Y)=U!(Y="") S IBQUIT=1 G SORTQ
D IBSRTCOM(IBSORTA,IBWORK) G SORTQ
;
SORTQ ; sort exit point
;
I IBQUIT S IBSORTA=IBOSRT I 'IBSORTA D IBASE
D FULL^VALM1
; update header and build output array for SHOW^VALM
I $G(IBSACT)=3 D HDR("All"),BVA
I $G(IBSACT)=4 D HDR("Active"),AC
I $G(IBSACT)=5 D HDR("Inactive"),IS
S VALMBCK="R",VALMBG=1
Q
;
IBSRTNM ; subscriber name sort type and order
;
N X,Y
S Y=$$IBSRQU("Subscriber Name","",0)
I $E(Y)=U!(Y="") S IBQUIT=1 Q
D IBSRTCOM(IBSORTA,IBWORK)
Q
;
;
IBSRQU(IBSRNM,IBSRF,IBSRR) ; get the type
;
; IBSRNM - sort name
; IBSRF - default response "" =none, 1 =Ascending, 2 =Descending
; IBSRR - required response 0 or "" =no, 1 =yes
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,IBQUIT,X,Y
K DIR S IBSRF=$G(IBSRF)
S DIR(0)="S"_($S(+IBSRR:"",1:"O"))_"^1:Ascending "_IBSRNM_";2:Descending "_IBSRNM
I IBSRF'="" S DIR("B")=IBSRF
S DIR("A")="SELECT 1 or 2"
S DIR("?")="Select Ascending or Descending "_IBSRNM_" or Enter '^' to quit"
D ^DIR
I Y=""&(IBSRF'="") S Y=IBSRF
I $E(Y)=U!$D(DIROUT)!$D(DIRUT)!$D(DTOUT)!$D(DUOUT) S Y="^"
S IBWORK=""
S IBWORK=$S(+Y=2:"-1",1:"1")
Q Y
;
IBSRTCOM(IBSORTA,IBWORK) ; go thru the compiled and sort for display
;
; IBSORTA - Sort Type
; IBWORK - Sort Order
;
; 3=ALL-9, 4=ACTIVE-10, 5=INACTIVE-11
; 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 ^^ 4 digit DOB year
; ^ 4 digit eff dt year ^ 4 digit exp dt year
N IBA,IBC,IBD,IBE,IBF,IBI,IBJ,IBK
I IBSORTA="" Q ; sort not picked
; 1 Subscriber Name
; 2 Date of Birth
; 3 Effective Date
; 4 Expiration Date
;
; cycle through all, active, inactive
S IBI=IBSACT K ^TMP("IBCNSJ53I",$J,IBI)
; to save time only clear and sort for the current display
S IBI=(IBSACT+6) K ^TMP("IBCNSJ53I",$J,"TEMP"),^TMP("IBCNSJ53I",$J,"TEMPA")
S IBA="" F S IBA=$O(^TMP("IBCNSJ53I",$J,IBI,IBA)) D:IBA="" IBSRTMV Q:IBA="" D
. S IBB="" F S IBB=$O(^TMP("IBCNSJ53I",$J,IBI,IBA,IBB)) Q:IBB="" D
.. S IBC=$G(^TMP("IBCNSJ53I",$J,IBI,IBA,IBB)),(IBD,IBJ)=""
.. I IBSORTA=1 S IBD=$P(IBC,U,1) S:IBD="" IBD=" " D IBSV Q
.. I IBSORTA=2!(IBSORTA=3)!(IBSORTA=4) S IBD="",IBK=$S(IBSORTA=2:12,IBSORTA=3:13,IBSORTA=4:14,1:"") D
... S:IBK IBD=$P(IBC,U,IBK) S IBJ=""
... D DT^DILF(,IBD,.IBJ) S IBD=$G(IBJ) S:IBD="" IBD=" " S:IBD="-1" IBD=" "
... I $E(IBD)'=" " D IBSV Q
... I $E(IBD)=" " D IBSVA Q
;
K ^TMP("IBCNSJ53I",$J,"TEMP"),^TMP("IBCNSJ53I",$J,"TEMPA")
Q
;
IBSV ; save in selected item order to temp area
;
S ^TMP("IBCNSJ53I",$J,"TEMP",IBD,IBA,IBB)=IBC
Q
;
IBSVA ; save invalid dates in selected item order to temp area
;
S ^TMP("IBCNSJ53I",$J,"TEMP",IBD,IBA,IBB)=IBC
Q
;
IBSRTMV ; move from temp and place in viewing order
;
N IBCT,IBG,IBH,IBK,IBJ
S IBK=$S(IBWORK="-1":"ZZZZZ",1:""),IBCT=0
I IBWORK'="-1" D IBSRTA
F S IBK=$O(^TMP("IBCNSJ53I",$J,"TEMP",IBK),IBWORK) Q:IBK="" D
. I $E(IBK)=" " Q
. S IBG=$S(IBWORK="-1":"ZZZZZ",1:"")
. F S IBG=$O(^TMP("IBCNSJ53I",$J,"TEMP",IBK,IBG),IBWORK) Q:IBG="" D
.. S IBH=$S(IBWORK="-1":"ZZZZZ",1:"")
.. F S IBH=$O(^TMP("IBCNSJ53I",$J,"TEMP",IBK,IBG,IBH),IBWORK) Q:IBH="" D
... S IBJ=$G(^TMP("IBCNSJ53I",$J,"TEMP",IBK,IBG,IBH))
... S IBCT=IBCT+1,^TMP("IBCNSJ53I",$J,(IBI-6),IBCT,IBG,IBH)=IBJ
I IBWORK="-1" D IBSRTA
Q
;
IBSRTA ; pick up blank and bad date items
;
N IBA,IBB,IBC,IBD,IBE
I IBWORK'="-1" D
. F IBA=" "," " D IBSRTA1
I IBWORK="-1" D
. F IBA=" "," " D IBSRTA1
Q
;
IBSRTA1 ; loop through bad/blank dates
;
S IBB=$S(IBWORK="-1":"ZZZZZ",1:"")
F S IBB=$O(^TMP("IBCNSJ53I",$J,"TEMP",IBA,IBB),IBWORK) Q:IBB="" D
. S IBC=$S(IBWORK="-1":"ZZZZZ",1:"")
. F S IBC=$O(^TMP("IBCNSJ53I",$J,"TEMP",IBA,IBB,IBC),IBWORK) Q:IBC="" D
.. S IBD=$G(^TMP("IBCNSJ53I",$J,"TEMP",IBA,IBB,IBC))
.. S IBCT=IBCT+1,^TMP("IBCNSJ53I",$J,(IBI-6),IBCT,IBB,IBC)=IBD
Q
;
IBASE ; reset levels to base
;
;IB*804/DTG add sort to view subscribers
; base set of values
N IBA,IBB,IBC,IBCNT,IBD,IBI
F IBA=3,4,5 K ^TMP("IBCNSJ53I",$J,IBA)
F IBI=9,10,11 S IBA="",IBCNT=0 F S IBA=$O(^TMP("IBCNSJ53I",$J,IBI,IBA)) Q:IBA="" S IBB="" D
. F S IBB=$O(^TMP("IBCNSJ53I",$J,IBI,IBA,IBB)) Q:IBB="" D
.. S IBD=^TMP("IBCNSJ53I",$J,IBI,IBA,IBB),IBCNT=IBCNT+1
.. S ^TMP("IBCNSJ53I",$J,(IBI-6),IBCNT,IBA,IBB)=IBD
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSJ53 17749 printed Sep 23, 2025@19:53:37 Page 2
IBCNSJ53 ;AITC/DTG - INSURANCE PLAN MAINTENANCE ACTION VIEW SUBSCRIBER ; 15-MAY-2023
+1 ;;2.0;INTEGRATED BILLING;**763,771,778,804**;21-MAR-94;Build 6
+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 ;IB*804/DTG add sort to view subscribers
+57 ;F IBA=3,4,5 K @IBTMP@(IBA)
+58 FOR IBA=3,4,5,9,10,11
KILL @IBTMP@(IBA)
+59 ;
+60 SET IBPTDFN=0
+61 FOR
SET IBPTDFN=$ORDER(^DPT("AB",IB36,IBPTDFN))
if 'IBPTDFN
QUIT
SET IBPTINS=0
Begin DoDot:1
+62 FOR
SET IBPTINS=$ORDER(^DPT("AB",IB36,IBPTDFN,IBPTINS))
if 'IBPTINS
QUIT
Begin DoDot:2
+63 SET IBA=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",.18,"I")
IF IBA=IB3553
Begin DoDot:3
+64 SET IBIND=$$ZND^IBCNS1(IBPTDFN,IBPTINS)
+65 SET IBCST=IBCST+1
+66 SET X=$$PT^IBEFUNC(IBPTDFN)
+67 ; Patient's Name (22 chars)
SET IBNAM=$EXTRACT($PIECE(X,"^",1),1,22)
+68 if IBNAM=""
SET IBNAM="<Pt. "_IBPTDFN_" Name Missing>"
+69 SET IBPTHOLD=IBNAM
+70 ; Retrieve last 4 of SSN (last 5 if pseudo SSN)
+71 ; Patient's SSN
SET XX=$$GET1^DIQ(2,IBPTDFN_",",.09,"I")
+72 SET XX=$SELECT($EXTRACT(XX,$LENGTH(XX))="P":$EXTRACT(XX,$LENGTH(XX)-4,$LENGTH(XX)),1:$EXTRACT(XX,$LENGTH(XX)-3,$LENGTH(XX)))
+73 SET $PIECE(IBPTHOLD,"^",2)=XX
+74 ; Patient's DOB
SET IBDOB=$$GET1^DIQ(2,IBPTDFN_",",.03,"I")
SET XX=$$DTC(IBDOB)
+75 SET $PIECE(IBPTHOLD,"^",3)=XX
+76 ;IB*804/DTG add in the 5 digit date for sort
SET XX=$$DTC5(IBDOB)
SET $PIECE(IBPTHOLD,"^",12)=XX
+77 SET XX=$PIECE(IBIND,"^",2)
SET XX=$SELECT(XX'="":XX,1:"<NO SUBS ID>")
+78 ; Subscriber ID (20 chars max)
SET $PIECE(IBPTHOLD,"^",4)=XX
+79 ; Effective Date
SET IBEFFDT=$PIECE(IBIND,"^",8)
SET XX=$$DTC(IBEFFDT)
+80 SET $PIECE(IBPTHOLD,"^",5)=XX
+81 ;IB*804/DTG add in the 5 digit date for sort
SET XX=$$DTC5(IBEFFDT)
SET $PIECE(IBPTHOLD,"^",13)=XX
+82 ; Expiration Date
SET IBEXPDT=$PIECE(IBIND,"^",4)
SET XX=$$DTC(IBEXPDT)
+83 SET $PIECE(IBPTHOLD,"^",6)=XX
+84 ;IB*804/DTG add in the 5 digit date for sort
SET XX=$$DTC5(IBEXPDT)
SET $PIECE(IBPTHOLD,"^",14)=XX
+85 ; Whose Insurance?
+86 SET XX=$PIECE(IBIND,"^",6)
SET XX=$SELECT(XX="v":"VET",XX="s":"SPO",XX="o":"OTH",1:"UNK")
+87 SET $PIECE(IBPTHOLD,"^",7)=XX
+88 ; Patient ID
SET XX=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",5.01,"I")
+89 SET $PIECE(IBPTHOLD,"^",8)=XX
+90 ; IB*778/DTG removed code for unused variable LENPID
+91 ;active or inactive
+92 SET (IBACT,IBINACT)=0
Begin DoDot:4
+93 ;
+94 ; if not a valid effective date count inactive
IF 'IBEFFDT!($PIECE(IBPTHOLD,U,5)="")
SET IBINACT=1
QUIT
+95 ;
+96 ; if there is a valid expiration date
IF (IBEXPDT'=""&($PIECE(IBPTHOLD,U,6)'=""))
Begin DoDot:5
+97 ;
+98 ; if the expiration date is less than today count inactive
IF IBEXPDT<DT
SET IBINACT=1
QUIT
+99 ;
+100 ; otherwise count active
SET IBACT=1
End DoDot:5
QUIT
+101 ;
+102 ; 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
+103 ;
+104 ; otherwise count active
SET IBACT=1
+105 ;
End DoDot:4
SET $PIECE(IBPTHOLD,U,9)=IBACT
SET $PIECE(IBPTHOLD,U,10)=IBINACT
+106 SET IBACCT=IBACCT+IBACT
SET IBINACCT=IBINACCT+IBINACT
+107 ;
+108 ;end active or inactive
+109 ;
+110 ; 3=ALL, 4=ACTIVE, 5=INACTIVE
+111 ; Patient's Name (22 chars) ^ Patient's SSN ^ Patient's DOB ^ Subscriber ID (20 chars max)
+112 ; ^ Effective Date ^ Expiration Date ^ Whose Insurance? ^ Patient ID ^ ACTIVE ^ INACTIVE ^^ 4 digit DOB year
+113 ; ^ 4 digit eff dt year ^ 4 digit exp dt year
+114 ; IB*804/DTG add sort to view subscribers
+115 ;S @IBTMP@(3,IB3553,IBNAM_"@@"_IBPTDFN_"@@"_IBPTINS)=IBPTHOLD
+116 ;S @IBTMP@(($S(IBACT=1:4,1:5)),IB3553,IBNAM_"@@"_IBPTDFN_"@@"_IBPTINS)=IBPTHOLD
+117 SET @IBTMP@(9,IB3553,IBNAM_"@@"_IBPTDFN_"@@"_IBPTINS)=IBPTHOLD
+118 SET @IBTMP@(($SELECT(IBACT=1:10,1:11)),IB3553,IBNAM_"@@"_IBPTDFN_"@@"_IBPTINS)=IBPTHOLD
+119 ; total ^ active ^ inactive
+120 SET @IBTMP@(0)=+IBCST_U_+IBACCT_U_+IBINACCT
End DoDot:3
End DoDot:2
End DoDot:1
+121 ;
+122 ;IB*804/DTG add sort to view subscribers
+123 ; base set of values
+124 DO IBASE
+125 ;
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 ;
DTC5(IBDTCK) ; check date return external if valid ;IB*804/DTG 4 digit year for sort's
+1 ;
+2 NEW IBDT,IBBK
SET IBDT=""
+3 IF 'IBDTCK
GOTO DTCO
+4 SET IBDT=$$FMTE^XLFDT(IBDTCK,"5DZ")
+5 ;
+6 GOTO DTC5O
+7 ;
DTC5O ; 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 ; IB*804/DTG add sort to view subscribers
+9 ;W !," Enter VA to see all subscribers.",!
+10 WRITE !," Enter VA to see all subscribers."
+11 WRITE !," Enter ST to sort the subscriber records",!
+12 SET DIR(0)="E"
SET DIR("A")="Press <Enter> to return to View Subscribers"
+13 DO ^DIR
+14 KILL DIR,X,Y
+15 SET VALMBCK="R"
+16 QUIT
+17 ;
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 ;IB*804/DTG add sort to view subscribers. default sort type is all
SET (IBOSRT,IBSORTA)=0
SET IBSACT=3
+7 KILL @IBTMP
+8 DO NOW^%DTC
+9 SET IBHDT=$$DAT2^IBOUTL($EXTRACT(%,1,12))
+10 SET IBSPACE=""
SET $PIECE(IBSPACE," ",80)=""
+11 IF IB36<1!(IB3553<1)
Begin DoDot:1
+12 WRITE !!,*7,"Missing Insurance or Plan IEN."
End DoDot:1
QUIT
+13 ;
+14 DO KILL^VALM10()
+15 ;
+16 DO VSUBS
+17 ;
+18 DO BVA
+19 SET VALMBCK="R"
SET VALMBG=1
+20 QUIT
+21 ;
ACINI ; active subscribers
+1 ;
+2 ; IB*804/DTG VS sort
SET IBSORTA=""
SET IBSACT=4
DO IBASE
+3 DO FULL^VALM1
+4 DO HDR("Active")
+5 DO AC
+6 SET VALMBCK="R"
SET VALMBG=1
+7 QUIT
+8 ;
ININI ; inactive subscribers
+1 ;
+2 ; IB*804/DTG VS sort
SET IBSORTA=""
SET IBSACT=5
DO IBASE
+3 DO FULL^VALM1
+4 DO HDR("Inactive")
+5 DO IS
+6 SET VALMBCK="R"
SET VALMBG=1
+7 QUIT
+8 ;
ALLINI ; all subscribers
+1 ;
+2 ; IB*804/DTG VS sort
SET IBSORTA=""
SET IBSACT=3
DO IBASE
+3 DO FULL^VALM1
+4 DO HDR("All")
+5 DO BVA
+6 SET VALMBCK="R"
SET VALMBG=1
+7 QUIT
+8 ;
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 ; IB*804/DTG include sorts in view subscriber
+12 NEW IB5,IBLA
SET (IB5,IBLA)=""
+13 ;IB*804/DTG added in for sort type if none chosen
IF '$GET(IBSORTA)
SET IB5="Sort by: NAME"
+14 IF $GET(IBSORTA)
SET IB5="Sort by: "_$SELECT(IBSORTA=1:"NAME",IBSORTA=2:"DOB",IBSORTA=3:"EFF DATE",IBSORTA=4:"EXP DATE",1:"")
+15 ;S IBL=(30-$L(IB1))+30,IB2=$E(IBSPACE,1,IBL)
+16 SET IBL=(35-$LENGTH(IB1))
SET IBLA=(25-$LENGTH(IB5))
SET IB2=$EXTRACT(IBSPACE,1,IBL)_IB5_$EXTRACT(IBSPACE,1,IBLA)
+17 ;
+18 SET IB3="TOTAL SUB: "_($EXTRACT(IBSPACE,1,(8-($LENGTH(+$PIECE(IBC,U,1))))))_(+$PIECE(IBC,U,1))
+19 SET VALMHDR(1)=IB1_IB2_IB3
+20 ;
+21 ; ins addr
SET IB1=$EXTRACT($PIECE(IBA,U,2),1,35)
+22 SET IBE=$EXTRACT($PIECE(IBB,U,2),1,(21+($SELECT(IBF2="+":1,1:0))))
+23 SET IBL=(35-$LENGTH(IB1))+(1+($SELECT(IBF2="+":0,1:1)))
+24 ; group name
SET IB2=$EXTRACT(IBSPACE,1,IBL)_IBE
+25 SET IBL=(($SELECT(IBF2="+":22,1:21))-$LENGTH(IBE))+1
+26 SET IB3=$EXTRACT(IBSPACE,1,IBL)_"ACTIVE SUB: "_($EXTRACT(IBSPACE,1,(8-($LENGTH(+$PIECE(IBC,U,2))))))_(+$PIECE(IBC,U,2))
+27 SET VALMHDR(2)=IB1_IB2_IB3
+28 ;
+29 ; city, state zip
SET IB1=$EXTRACT($PIECE(IBA,U,7),1,35)
+30 SET IBE=$EXTRACT($PIECE(IBB,U,1),1,(19+($SELECT(IBF1="*":1,1:0))))
+31 SET IBL=(35-($LENGTH(IB1))+(1+($SELECT(IBF1="*":0,1:1))))
+32 ; group number
SET IB2=$EXTRACT(IBSPACE,1,IBL)_IBE
+33 SET IBL=(($SELECT(IBF1="*":20,1:19))-$LENGTH(IBE))+1
+34 SET IB3=$EXTRACT(IBSPACE,1,IBL)_"INACTIVE SUB: "_($EXTRACT(IBSPACE,1,(8-($LENGTH(+$PIECE(IBC,U,3))))))_(+$PIECE(IBC,U,3))
+35 SET VALMHDR(3)=IB1_IB2_IB3
+36 ;
+37 QUIT
+38 ;
BVA ; Build ALL subscribers
+1 ;
+2 NEW IBLINE,IBTMP1,IBF
+3 ;IB*804/DTG chage array for sort
+4 ;S IBTMP1="^TMP(""IBCNSJ53I"",$J,3,"_IB3553_")"
+5 SET IBTMP1="^TMP(""IBCNSJ53I"",$J,3)"
+6 SET VALMCNT=0
SET VALMBG=1
SET IBLINE=0
+7 KILL @VALMAR
+8 SET IBF=$GET(^TMP("IBCNSJ53I",$JOB,0))
+9 ; IB*771/DTG put none found back in display
IF '+IBF
Begin DoDot:1
+10 SET VALMCNT=2
SET @VALMAR@(1,0)=" "
+11 SET @VALMAR@(2,0)=" ***Group Contains No Subscribers***"
End DoDot:1
QUIT
+12 ; go through the 3 level
+13 DO BPAS
+14 QUIT
+15 ;
BPAS ; build items from base into valm display
+1 ;
+2 NEW IBA,IBB,IBC,IBD,IBE,IBNM,IBDFN,IBNODE,X
+3 ;S IBA="",X="" F S IBA=$O(@IBTMP1@(IBA)) Q:IBA="" D
+4 ; IB*804/DTG include sorts in view subscriber Change from a single dot '.' level to three dot '.' levels
+5 ;S IBA="",X="" F S IBA=$O(@IBTMP1@(IBA)) Q:IBA="" D
+6 NEW IBCNTR,IBG
+7 SET IBCNTR=""
FOR
SET IBCNTR=$ORDER(@IBTMP1@(IBCNTR))
if IBCNTR=""
QUIT
SET IBG=""
Begin DoDot:1
+8 FOR
SET IBG=$ORDER(@IBTMP1@(IBCNTR,IBG))
if IBG=""
QUIT
SET IBA=""
SET X=""
Begin DoDot:2
+9 FOR
SET IBA=$ORDER(@IBTMP1@(IBCNTR,IBG,IBA))
if IBA=""
QUIT
Begin DoDot:3
+10 SET IBNM=$PIECE(IBA,"@@",1)
SET IBDFN=$PIECE(IBA,"@@",2)
SET IBNODE=$PIECE(IBA,"@@",3)
+11 SET VALMCNT=VALMCNT+1
SET IBC=@IBTMP1@(IBCNTR,IBG,IBA)
SET X=""
SET IBLINE=IBLINE+1
+12 SET X=$$SETFLD^VALM1($PIECE(IBC,"^",1),X,"SNAME")
+13 SET X=$$SETFLD^VALM1($PIECE(IBC,"^",2),X,"SSN4")
+14 SET X=$$SETFLD^VALM1($PIECE(IBC,U,3),X,"DOB10")
+15 SET X=$$SETFLD^VALM1($PIECE(IBC,"^",4),X,"SUBID")
+16 SET X=$$SETFLD^VALM1($PIECE(IBC,U,5),X,"EFFDT")
+17 SET X=$$SETFLD^VALM1($PIECE(IBC,U,6),X,"EXPDT")
+18 SET X=$$SETFLD^VALM1($PIECE(IBC,"^",7),X,"WHO")
+19 SET X=$$SETFLD^VALM1($PIECE(IBC,"^",8),X,"PATID")
+20 SET IBD=$PIECE(IBC,U,9)
SET X=$$SETFLD^VALM1($SELECT(IBD=1:"Y",1:""),X,"ACT")
+21 SET @VALMAR@(VALMCNT,0)=X
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
AC ; active subscriber entry
+1 ;
+2 NEW IBLINE,IBTMP1,IBF
+3 ;IB*804/DTG chage array for sort
+4 ;S IBTMP1="^TMP(""IBCNSJ53I"",$J,4,"_IB3553_")"
+5 SET IBTMP1="^TMP(""IBCNSJ53I"",$J,4)"
+6 SET VALMCNT=0
SET VALMBG=1
SET IBLINE=0
+7 KILL @VALMAR
+8 SET IBF=$GET(^TMP("IBCNSJ53I",$JOB,0))
+9 IF '+$PIECE(IBF,U,2)
Begin DoDot:1
+10 SET VALMCNT=2
SET @VALMAR@(1,0)=" "
+11 SET @VALMAR@(2,0)=" ***Group Contains No Active Subscribers***"
End DoDot:1
QUIT
+12 ; go through the 4 level
+13 DO BPAS
+14 QUIT
+15 ;
IS ; inactive subscriber entry
+1 ;
+2 NEW IBLINE,IBTMP1,IBF
+3 ;IB*804/DTG chage array for sort
+4 ;S IBTMP1="^TMP(""IBCNSJ53I"",$J,5,"_IB3553_")"
+5 SET IBTMP1="^TMP(""IBCNSJ53I"",$J,5)"
+6 SET VALMCNT=0
SET VALMBG=1
SET IBLINE=0
+7 KILL @VALMAR
+8 SET IBF=$GET(^TMP("IBCNSJ53I",$JOB,0))
+9 IF '+$PIECE(IBF,U,3)
Begin DoDot:1
+10 SET VALMCNT=2
SET @VALMAR@(1,0)=" "
+11 SET @VALMAR@(2,0)=" ***Group Contains No Inactive Subscribers***"
End DoDot:1
QUIT
+12 ; go through the 5 level
+13 DO BPAS
+14 QUIT
+15 ;
+16 ;IB*804/DTG new for sort SORT - IBASE
SORT ; ask sort questions if sort selected then re-build ^TMP("IBCNSJ53I",$J,
+1 ;
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,IBJ,IBQUIT,IBSRF,IBSRNM,IBWORK,X,Y
+3 SET IBQUIT=0
+4 DO FULL^VALM1
+5 SET IBSACT=$GET(IBSACT)
IF IBSACT<3
SET IBSACT=3
+6 SET IBOSRT=IBSORTA
+7 KILL DIR
SET DIR(0)="S^1:Subscriber Name;2:Date of Birth;3:Effective Date;4:Expiration Date"
+8 SET DIR("A")="SELECT 1, 2, 3, or 4"
+9 SET DIR("?")="Select a sort method or Enter '^' to quit"
+10 SET DIR("B")=$SELECT(IBOSRT=2:"Date of Birth",IBOSRT=3:"Effective Date",IBOSRT=4:"Expiration Date",1:"Subscriber Name")
+11 DO ^DIR
+12 IF $EXTRACT(Y)=U!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)
SET Y="^"
+13 IF $EXTRACT(Y)=U
SET IBQUIT=1
GOTO SORTQ
+14 SET IBSORTA=+Y
IF Y<1
SET IBQUIT=1
GOTO SORTQ
+15 IF IBSORTA=1
DO IBSRTNM
GOTO SORTQ
+16 SET IBJ=$SELECT(IBSORTA=2:"Date of Birth",IBSORTA=3:"Effective Date",IBSORTA=4:"Expiration Date",1:"")
+17 IF IBJ=""
SET IBQUIT=1
GOTO SORTQ
+18 SET Y=$$IBSRQU(IBJ,"",0)
+19 IF $EXTRACT(Y)=U!(Y="")
SET IBQUIT=1
GOTO SORTQ
+20 DO IBSRTCOM(IBSORTA,IBWORK)
GOTO SORTQ
+21 ;
SORTQ ; sort exit point
+1 ;
+2 IF IBQUIT
SET IBSORTA=IBOSRT
IF 'IBSORTA
DO IBASE
+3 DO FULL^VALM1
+4 ; update header and build output array for SHOW^VALM
+5 IF $GET(IBSACT)=3
DO HDR("All")
DO BVA
+6 IF $GET(IBSACT)=4
DO HDR("Active")
DO AC
+7 IF $GET(IBSACT)=5
DO HDR("Inactive")
DO IS
+8 SET VALMBCK="R"
SET VALMBG=1
+9 QUIT
+10 ;
IBSRTNM ; subscriber name sort type and order
+1 ;
+2 NEW X,Y
+3 SET Y=$$IBSRQU("Subscriber Name","",0)
+4 IF $EXTRACT(Y)=U!(Y="")
SET IBQUIT=1
QUIT
+5 DO IBSRTCOM(IBSORTA,IBWORK)
+6 QUIT
+7 ;
+8 ;
IBSRQU(IBSRNM,IBSRF,IBSRR) ; get the type
+1 ;
+2 ; IBSRNM - sort name
+3 ; IBSRF - default response "" =none, 1 =Ascending, 2 =Descending
+4 ; IBSRR - required response 0 or "" =no, 1 =yes
+5 ;
+6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,IBQUIT,X,Y
+7 KILL DIR
SET IBSRF=$GET(IBSRF)
+8 SET DIR(0)="S"_($SELECT(+IBSRR:"",1:"O"))_"^1:Ascending "_IBSRNM_";2:Descending "_IBSRNM
+9 IF IBSRF'=""
SET DIR("B")=IBSRF
+10 SET DIR("A")="SELECT 1 or 2"
+11 SET DIR("?")="Select Ascending or Descending "_IBSRNM_" or Enter '^' to quit"
+12 DO ^DIR
+13 IF Y=""&(IBSRF'="")
SET Y=IBSRF
+14 IF $EXTRACT(Y)=U!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)
SET Y="^"
+15 SET IBWORK=""
+16 SET IBWORK=$SELECT(+Y=2:"-1",1:"1")
+17 QUIT Y
+18 ;
IBSRTCOM(IBSORTA,IBWORK) ; go thru the compiled and sort for display
+1 ;
+2 ; IBSORTA - Sort Type
+3 ; IBWORK - Sort Order
+4 ;
+5 ; 3=ALL-9, 4=ACTIVE-10, 5=INACTIVE-11
+6 ; Patient's Name (22 chars) ^ Patient's SSN ^ Patient's DOB ^ Subscriber ID (20 chars max)
+7 ; ^ Effective Date ^ Expiration Date ^ Whose Insurance? ^ Patient ID ^ ACTIVE ^ INACTIVE ^^ 4 digit DOB year
+8 ; ^ 4 digit eff dt year ^ 4 digit exp dt year
+9 NEW IBA,IBC,IBD,IBE,IBF,IBI,IBJ,IBK
+10 ; sort not picked
IF IBSORTA=""
QUIT
+11 ; 1 Subscriber Name
+12 ; 2 Date of Birth
+13 ; 3 Effective Date
+14 ; 4 Expiration Date
+15 ;
+16 ; cycle through all, active, inactive
+17 SET IBI=IBSACT
KILL ^TMP("IBCNSJ53I",$JOB,IBI)
+18 ; to save time only clear and sort for the current display
+19 SET IBI=(IBSACT+6)
KILL ^TMP("IBCNSJ53I",$JOB,"TEMP"),^TMP("IBCNSJ53I",$JOB,"TEMPA")
+20 SET IBA=""
FOR
SET IBA=$ORDER(^TMP("IBCNSJ53I",$JOB,IBI,IBA))
if IBA=""
DO IBSRTMV
if IBA=""
QUIT
Begin DoDot:1
+21 SET IBB=""
FOR
SET IBB=$ORDER(^TMP("IBCNSJ53I",$JOB,IBI,IBA,IBB))
if IBB=""
QUIT
Begin DoDot:2
+22 SET IBC=$GET(^TMP("IBCNSJ53I",$JOB,IBI,IBA,IBB))
SET (IBD,IBJ)=""
+23 IF IBSORTA=1
SET IBD=$PIECE(IBC,U,1)
if IBD=""
SET IBD=" "
DO IBSV
QUIT
+24 IF IBSORTA=2!(IBSORTA=3)!(IBSORTA=4)
SET IBD=""
SET IBK=$SELECT(IBSORTA=2:12,IBSORTA=3:13,IBSORTA=4:14,1:"")
Begin DoDot:3
+25 if IBK
SET IBD=$PIECE(IBC,U,IBK)
SET IBJ=""
+26 DO DT^DILF(,IBD,.IBJ)
SET IBD=$GET(IBJ)
if IBD=""
SET IBD=" "
if IBD="-1"
SET IBD=" "
+27 IF $EXTRACT(IBD)'=" "
DO IBSV
QUIT
+28 IF $EXTRACT(IBD)=" "
DO IBSVA
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+29 ;
+30 KILL ^TMP("IBCNSJ53I",$JOB,"TEMP"),^TMP("IBCNSJ53I",$JOB,"TEMPA")
+31 QUIT
+32 ;
IBSV ; save in selected item order to temp area
+1 ;
+2 SET ^TMP("IBCNSJ53I",$JOB,"TEMP",IBD,IBA,IBB)=IBC
+3 QUIT
+4 ;
IBSVA ; save invalid dates in selected item order to temp area
+1 ;
+2 SET ^TMP("IBCNSJ53I",$JOB,"TEMP",IBD,IBA,IBB)=IBC
+3 QUIT
+4 ;
IBSRTMV ; move from temp and place in viewing order
+1 ;
+2 NEW IBCT,IBG,IBH,IBK,IBJ
+3 SET IBK=$SELECT(IBWORK="-1":"ZZZZZ",1:"")
SET IBCT=0
+4 IF IBWORK'="-1"
DO IBSRTA
+5 FOR
SET IBK=$ORDER(^TMP("IBCNSJ53I",$JOB,"TEMP",IBK),IBWORK)
if IBK=""
QUIT
Begin DoDot:1
+6 IF $EXTRACT(IBK)=" "
QUIT
+7 SET IBG=$SELECT(IBWORK="-1":"ZZZZZ",1:"")
+8 FOR
SET IBG=$ORDER(^TMP("IBCNSJ53I",$JOB,"TEMP",IBK,IBG),IBWORK)
if IBG=""
QUIT
Begin DoDot:2
+9 SET IBH=$SELECT(IBWORK="-1":"ZZZZZ",1:"")
+10 FOR
SET IBH=$ORDER(^TMP("IBCNSJ53I",$JOB,"TEMP",IBK,IBG,IBH),IBWORK)
if IBH=""
QUIT
Begin DoDot:3
+11 SET IBJ=$GET(^TMP("IBCNSJ53I",$JOB,"TEMP",IBK,IBG,IBH))
+12 SET IBCT=IBCT+1
SET ^TMP("IBCNSJ53I",$JOB,(IBI-6),IBCT,IBG,IBH)=IBJ
End DoDot:3
End DoDot:2
End DoDot:1
+13 IF IBWORK="-1"
DO IBSRTA
+14 QUIT
+15 ;
IBSRTA ; pick up blank and bad date items
+1 ;
+2 NEW IBA,IBB,IBC,IBD,IBE
+3 IF IBWORK'="-1"
Begin DoDot:1
+4 FOR IBA=" "," "
DO IBSRTA1
End DoDot:1
+5 IF IBWORK="-1"
Begin DoDot:1
+6 FOR IBA=" "," "
DO IBSRTA1
End DoDot:1
+7 QUIT
+8 ;
IBSRTA1 ; loop through bad/blank dates
+1 ;
+2 SET IBB=$SELECT(IBWORK="-1":"ZZZZZ",1:"")
+3 FOR
SET IBB=$ORDER(^TMP("IBCNSJ53I",$JOB,"TEMP",IBA,IBB),IBWORK)
if IBB=""
QUIT
Begin DoDot:1
+4 SET IBC=$SELECT(IBWORK="-1":"ZZZZZ",1:"")
+5 FOR
SET IBC=$ORDER(^TMP("IBCNSJ53I",$JOB,"TEMP",IBA,IBB,IBC),IBWORK)
if IBC=""
QUIT
Begin DoDot:2
+6 SET IBD=$GET(^TMP("IBCNSJ53I",$JOB,"TEMP",IBA,IBB,IBC))
+7 SET IBCT=IBCT+1
SET ^TMP("IBCNSJ53I",$JOB,(IBI-6),IBCT,IBB,IBC)=IBD
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
IBASE ; reset levels to base
+1 ;
+2 ;IB*804/DTG add sort to view subscribers
+3 ; base set of values
+4 NEW IBA,IBB,IBC,IBCNT,IBD,IBI
+5 FOR IBA=3,4,5
KILL ^TMP("IBCNSJ53I",$JOB,IBA)
+6 FOR IBI=9,10,11
SET IBA=""
SET IBCNT=0
FOR
SET IBA=$ORDER(^TMP("IBCNSJ53I",$JOB,IBI,IBA))
if IBA=""
QUIT
SET IBB=""
Begin DoDot:1
+7 FOR
SET IBB=$ORDER(^TMP("IBCNSJ53I",$JOB,IBI,IBA,IBB))
if IBB=""
QUIT
Begin DoDot:2
+8 SET IBD=^TMP("IBCNSJ53I",$JOB,IBI,IBA,IBB)
SET IBCNT=IBCNT+1
+9 SET ^TMP("IBCNSJ53I",$JOB,(IBI-6),IBCNT,IBA,IBB)=IBD
End DoDot:2
End DoDot:1
+10 ;
+11 QUIT
+12 ;
