Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCNSJ53

IBCNSJ53.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ;
  1. VP ; -- Edit/View Plan  (VS entry point)
  1.  D FULL^VALM1
  1.  D EN^VALM("IBCNSC PLAN VIEW SUBSCRIBERS")
  1.  S VALMBCK="R",VALMBG=1
  1.  Q
  1.  ;
  1. VSUBS ; entry from list template protocol 'IBCNSJ PLAN VIEW SUBSCRIBERS' from the 'IBCNSC PLAN DETAIL' menu
  1.  ;
  1.  N DIR,FIEN,FTF,FTFV,IBA,IBB,IBC,IBD,IBDOB,IBDTCK,IBE,IBEFFDT,IBERR,IBEXPDT,IBF
  1.  N IBIND,IBINS0,IBNAM,IBPTDFN,IBPTHOLD,IBPTINS,NUM
  1.  N ST,X,XX,X0,X11,Y,Z
  1.  ; clear working array
  1.  S IBTMP="^TMP(""IBCNSJ53I"",$J)"
  1.  K @IBTMP
  1.  S (IBCST,IBACCT,IBINACCT,LENEP,LENPT)=0
  1.  ;set insurance CO. info
  1.  ;
  1.  S X0=$G(^DIC(36,IB36,0))
  1.  S X11=$G(^DIC(36,IB36,.11))
  1.  S Z=$P(X11,"^",6)
  1.  S ST=$S($P(X11,"^",5):$P($G(^DIC(5,$P(X11,"^",5),0)),"^",2),1:"")
  1.  S XX=$S($P(X0,"^",5):"*",1:"")
  1.  S X=XX_$E($P(X0,"^",1),1,30)
  1.  S $P(X,"^",2)=$P(X11,"^",1)
  1.  S $P(X,"^",3)=$P(X11,"^",4) S:$P(X,U,3)'="" $P(X,U,3)=$P(X,U,3)_","
  1.  S $P(X,"^",4)=$G(ST)
  1.  S $P(X,"^",5)=$E(Z,1,5)
  1.  S $P(X,"^",6)=""
  1.  S $P(X,U,7)=$P(X,U,3)_" "_$P(X,U,4)_" "_$P(X,U,5)
  1.  ; Insurance Company name (first 30 chars) with leading '*' if inactive ^ Street Address Line 1
  1.  ; ^ City ^ ST ^ ZIP ^
  1.  S @IBTMP@(1)=X
  1.  ;set plan info
  1.  ;            A1 - Group Plan Number (leading '*' if Inactive)
  1.  ;            A2 - Group Plan Name   (leading '+' if Individual)
  1.  ;            A3 - 
  1.  ;            A4 - Electronic Plan Type (max length 26)
  1.  ;            A5 - Type of Plan (max length 34)
  1.  ;
  1.  N IBFL1,IBFL2,NAME,NUM,XX,ZZ
  1.  S NUM=$$GET1^DIQ(355.3,IB3553,2.02)
  1.  S:NUM="" NUM="<NO GROUP NUMBER>"
  1.  S XX=$$GET1^DIQ(355.3,IB3553,.02,"I")     ; Group or Individual Plan
  1.  S IBFL1=$S(XX=1:"",1:"+")
  1.  S ZZ=$$GET1^DIQ(355.3,IB3553,.11,"I")     ; Inactive Flag
  1.  S IBFL2=$S(ZZ=1:"*",1:"")
  1.  S $P(XX,"^",1)=IBFL2_NUM                     ; Add Inactive/Individual flags
  1.  S NAME=$$GET1^DIQ(355.3,IB3553,2.01)
  1.  S:NAME="" NAME="<NO GROUP NAME>"
  1.  S $P(XX,"^",2)=IBFL1_NAME                       ; Group Name
  1.  S $P(XX,"^",3)=""
  1.  S ZZ=$$GET1^DIQ(355.3,IB3553_",",.15)       ; Electronic Plan Type
  1.  S:$L(ZZ)>$G(LENEP) LENEP=$L(ZZ)               ; Maximum Electronic Plan length
  1.  S $P(XX,"^",4)=ZZ
  1.  S ZZ=$$GET1^DIQ(355.3,IB3553_",",.09)       ; Type of Plan
  1.  S:$L(ZZ)>34 ZZ=$E(ZZ,1,34)
  1.  S:$L(ZZ)>$G(LENEP) LENEP=$L(ZZ)               ; Maximum Plan Type length
  1.  S $P(XX,"^",5)=ZZ
  1.  ; plan info
  1.  S @IBTMP@(2)=XX
  1.  S IBINS0=$G(^IBA(355.3,+IB3553,0))
  1.  ; get plan subscribers
  1.  F IBA=3,4,5 K @IBTMP@(IBA)
  1.  S IBPTDFN=0
  1.  F  S IBPTDFN=$O(^DPT("AB",IB36,IBPTDFN)) Q:'IBPTDFN  S IBPTINS=0 D
  1.  .F  S IBPTINS=$O(^DPT("AB",IB36,IBPTDFN,IBPTINS)) Q:'IBPTINS  D
  1.  ..S IBA=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",.18,"I") I IBA=IB3553 D
  1.  ...S IBIND=$$ZND^IBCNS1(IBPTDFN,IBPTINS)
  1.  ...S IBCST=IBCST+1
  1.  ...S X=$$PT^IBEFUNC(IBPTDFN)
  1.  ...S IBNAM=$E($P(X,"^",1),1,22)               ; Patient's Name (22 chars)
  1.  ...S:IBNAM="" IBNAM="<Pt. "_IBPTDFN_" Name Missing>"
  1.  ...S IBPTHOLD=IBNAM
  1.  ...; Retrieve last 4 of SSN (last 5 if pseudo SSN)
  1.  ...S XX=$$GET1^DIQ(2,IBPTDFN_",",.09,"I")         ; Patient's SSN
  1.  ...S XX=$S($E(XX,$L(XX))="P":$E(XX,$L(XX)-4,$L(XX)),1:$E(XX,$L(XX)-3,$L(XX)))
  1.  ...S $P(IBPTHOLD,"^",2)=XX
  1.  ...S IBDOB=$$GET1^DIQ(2,IBPTDFN_",",.03,"I"),XX=$$DTC(IBDOB)         ; Patient's DOB
  1.  ...S $P(IBPTHOLD,"^",3)=XX
  1.  ...S XX=$P(IBIND,"^",2),XX=$S(XX'="":XX,1:"<NO SUBS ID>")
  1.  ...S $P(IBPTHOLD,"^",4)=XX                         ; Subscriber ID (20 chars max)
  1.  ...S IBEFFDT=$P(IBIND,"^",8),XX=$$DTC(IBEFFDT)   ; Effective Date
  1.  ...S $P(IBPTHOLD,"^",5)=XX
  1.  ...S IBEXPDT=$P(IBIND,"^",4),XX=$$DTC(IBEXPDT)   ; Expiration Date
  1.  ...S $P(IBPTHOLD,"^",6)=XX
  1.  ...; Whose Insurance?
  1.  ...S XX=$P(IBIND,"^",6),XX=$S(XX="v":"VET",XX="s":"SPO",XX="o":"OTH",1:"UNK")
  1.  ...S $P(IBPTHOLD,"^",7)=XX
  1.  ...S XX=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",5.01,"I")  ; Patient ID
  1.  ...S $P(IBPTHOLD,"^",8)=XX
  1.  ...; IB*778/DTG removed code for unused variable LENPID
  1.  ...;active or inactive
  1.  ...S (IBACT,IBINACT)=0 D  S $P(IBPTHOLD,U,9)=IBACT,$P(IBPTHOLD,U,10)=IBINACT
  1.  ....;
  1.  ....I 'IBEFFDT!($P(IBPTHOLD,U,5)="") S IBINACT=1 Q  ; if not a valid effective date count inactive
  1.  ....;
  1.  ....I (IBEXPDT'=""&($P(IBPTHOLD,U,6)'="")) D  Q  ; if there is a valid expiration date
  1.  .....;
  1.  .....I IBEXPDT<DT S IBINACT=1 Q  ; if the expiration date is less than today count inactive
  1.  .....;
  1.  .....S IBACT=1  ; otherwise count active
  1.  ....;
  1.  ....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
  1.  ....;
  1.  ....S IBACT=1  ; otherwise count active
  1.  ....;
  1.  ...S IBACCT=IBACCT+IBACT,IBINACCT=IBINACCT+IBINACT
  1.  ...;
  1.  ...;end active or inactive
  1.  ...;
  1.  ...; 3=ALL, 4=ACTIVE, 5=INACTIVE
  1.  ...; Patient's Name (22 chars) ^ Patient's SSN ^ Patient's DOB ^ Subscriber ID (20 chars max)
  1.  ...; ^ Effective Date ^ Expiration Date ^ Whose Insurance? ^ Patient ID ^ ACTIVE ^ INACTIVE
  1.  ...S @IBTMP@(3,IB3553,IBNAM_"@@"_IBPTDFN_"@@"_IBPTINS)=IBPTHOLD
  1.  ...S @IBTMP@(($S(IBACT=1:4,1:5)),IB3553,IBNAM_"@@"_IBPTDFN_"@@"_IBPTINS)=IBPTHOLD
  1.  ...; total ^ active ^ inactive
  1.  ...S @IBTMP@(0)=+IBCST_U_+IBACCT_U_+IBINACCT
  1.  ;
  1. VSUBX ; quit back
  1.  ;
  1.  Q
  1. DTC(IBDTCK) ; check date return external if valid
  1.  ;
  1.  N IBDT,IBBK S IBDT=""
  1.  I 'IBDTCK G DTCO
  1.  S IBDT=$$FMTE^XLFDT(IBDTCK,"2DZ")
  1.  ;
  1.  G DTCO
  1.  ;
  1. DTCO ; date check exit
  1.  ;
  1.  Q IBDT
  1.  ;
  1. EXIT ; -- exit code
  1.  K VALMBCK,^TMP("IBCNSJ53",$J),^TMP("IBCNSJ53I",$J),IBVPCLBG,IBVPCLEN
  1.  D CLEAN^VALM10,CLEAR^VALM1
  1.  S VALMBCK="R",VALMBG=1
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  ;
  1.  I $G(VALMANS)="??" S X="?" D DISP^XQORM1 W !! Q
  1.  D FULL^VALM1
  1.  N DIR,X,Y
  1.  W !
  1.  W !," Enter AC to only see active subscribers."
  1.  W !," Enter IN to only see inactive subscribers."
  1.  W !," Enter VA to see all subscribers.",!
  1.  S DIR(0)="E",DIR("A")="Press <Enter> to return to View Subscribers"
  1.  D ^DIR
  1.  K DIR,X,Y
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. INIT ; -- Load the plan detail segments
  1.  ;
  1.  K ^TMP("IBCNSJ53",$J)
  1.  S VALMBG=1,(IBLCNT,VALMCNT)=0
  1.  S IB36=+$G(IBCNS),IB3553=+$G(IBCPOL)
  1.  S IBTMP="^TMP(""IBCNSJ53I"",$J)",(IBCST,IBACCT,IBINACCT,LENEP,LENPT)=0
  1.  K @IBTMP
  1.  D NOW^%DTC
  1.  S IBHDT=$$DAT2^IBOUTL($E(%,1,12))
  1.  S IBSPACE="",$P(IBSPACE," ",80)=""
  1.  I IB36<1!(IB3553<1) D  Q
  1.  . W !!,*7,"Missing Insurance or Plan IEN."
  1.  ;
  1.  D KILL^VALM10()
  1.  ;
  1.  D VSUBS
  1.  ;
  1.  D BVA
  1.  S VALMBCK="R",VALMBG=1
  1.  Q
  1.  ;
  1. ACINI ; active subscribers
  1.  ;
  1.  D FULL^VALM1
  1.  D HDR("Active")
  1.  D AC
  1.  S VALMBCK="R",VALMBG=1
  1.  Q
  1.  ;
  1. ININI ; inactive subscribers
  1.  ;
  1.  D FULL^VALM1
  1.  D HDR("Inactive")
  1.  D IS
  1.  S VALMBCK="R",VALMBG=1
  1.  Q
  1.  ;
  1. ALLINI ; all subscribers
  1.  ;
  1.  D FULL^VALM1
  1.  D HDR("All")
  1.  D BVA
  1.  S VALMBCK="R",VALMBG=1
  1.  Q
  1.  ;
  1. HDR(IBDIS) ; -- Plan Subscribers
  1.  ;
  1.  N IBA,IBB,IBC,IBD,IBE,IBF1,IBF2,IBL,IB1,IB2,IB3
  1.  S (IB1,IB2,IB3)=""
  1.  S IBA=$G(^TMP("IBCNSJ53I",$J,1)),IBB=$G(^TMP("IBCNSJ53I",$J,2)),IBC=$G(^TMP("IBCNSJ53I",$J,0))
  1.  S IBF2=$E($P(IBB,U,2))
  1.  S IBF1=$E($P(IBB,U,1))
  1.  S IBDIS=$G(IBDIS),IBDIS=$S(IBDIS'="":IBDIS,1:"All")
  1.  S VALM("TITLE")=IBDIS_" Subscribers"
  1.  ;
  1.  S IB1=$E($P(IBA,U,1),1,30) ; ins co name
  1.  S IBL=(30-$L(IB1))+30,IB2=$E(IBSPACE,1,IBL)
  1.  S IB3="TOTAL SUB: "_($E(IBSPACE,1,(8-($L(+$P(IBC,U,1))))))_(+$P(IBC,U,1))
  1.  S VALMHDR(1)=IB1_IB2_IB3
  1.  ;
  1.  S IB1=$E($P(IBA,U,2),1,35)  ; ins addr
  1.  S IBE=$E($P(IBB,U,2),1,(21+($S(IBF2="+":1,1:0))))
  1.  S IBL=(35-$L(IB1))+(1+($S(IBF2="+":0,1:1)))
  1.  S IB2=$E(IBSPACE,1,IBL)_IBE ; group name
  1.  S IBL=(($S(IBF2="+":22,1:21))-$L(IBE))+1
  1.  S IB3=$E(IBSPACE,1,IBL)_"ACTIVE SUB: "_($E(IBSPACE,1,(8-($L(+$P(IBC,U,2))))))_(+$P(IBC,U,2))
  1.  S VALMHDR(2)=IB1_IB2_IB3
  1.  ;
  1.  S IB1=$E($P(IBA,U,7),1,35)  ; city, state zip
  1.  S IBE=$E($P(IBB,U,1),1,(19+($S(IBF1="*":1,1:0))))
  1.  S IBL=(35-($L(IB1))+(1+($S(IBF1="*":0,1:1))))
  1.  S IB2=$E(IBSPACE,1,IBL)_IBE  ; group number
  1.  S IBL=(($S(IBF1="*":20,1:19))-$L(IBE))+1
  1.  S IB3=$E(IBSPACE,1,IBL)_"INACTIVE SUB: "_($E(IBSPACE,1,(8-($L(+$P(IBC,U,3))))))_(+$P(IBC,U,3))
  1.  S VALMHDR(3)=IB1_IB2_IB3
  1.  ;
  1.  Q
  1.  ;
  1. BVA ; Build ALL subscribers
  1.  ;
  1.  N IBLINE,IBTMP1,IBF
  1.  S IBTMP1="^TMP(""IBCNSJ53I"",$J,3,"_IB3553_")"
  1.  S VALMCNT=0,VALMBG=1,IBLINE=0
  1.  K @VALMAR
  1.  S IBF=$G(^TMP("IBCNSJ53I",$J,0))
  1.  I '+IBF D  Q  ; IB*771/DTG put none found back in display
  1.  . S VALMCNT=2,@VALMAR@(1,0)=" "
  1.  . S @VALMAR@(2,0)=" ***Group Contains No Subscribers***"
  1.  ; go through the 3 level
  1.  D BPAS
  1.  Q
  1.  ;
  1. BPAS ; build items from base into valm display
  1.  ;
  1.  N IBA,IBB,IBC,IBD,IBE,IBNM,IBDFN,IBNODE,X
  1.  S IBA="",X="" F  S IBA=$O(@IBTMP1@(IBA)) Q:IBA=""  D
  1.  . S IBNM=$P(IBA,"@@",1),IBDFN=$P(IBA,"@@",2),IBNODE=$P(IBA,"@@",3)
  1.  . S VALMCNT=VALMCNT+1,IBC=@IBTMP1@(IBA),X="",IBLINE=IBLINE+1
  1.  . S X=$$SETFLD^VALM1($P(IBC,"^",1),X,"SNAME")
  1.  . S X=$$SETFLD^VALM1($P(IBC,"^",2),X,"SSN4")
  1.  . S X=$$SETFLD^VALM1($P(IBC,U,3),X,"DOB10")
  1.  . S X=$$SETFLD^VALM1($P(IBC,"^",4),X,"SUBID")
  1.  . S X=$$SETFLD^VALM1($P(IBC,U,5),X,"EFFDT")
  1.  . S X=$$SETFLD^VALM1($P(IBC,U,6),X,"EXPDT")
  1.  . S X=$$SETFLD^VALM1($P(IBC,"^",7),X,"WHO")
  1.  . S X=$$SETFLD^VALM1($P(IBC,"^",8),X,"PATID")
  1.  . S IBD=$P(IBC,U,9),X=$$SETFLD^VALM1($S(IBD=1:"Y",1:""),X,"ACT")
  1.  . S @VALMAR@(VALMCNT,0)=X
  1.  Q
  1.  ;
  1. AC ; active subscriber entry
  1.  ;
  1.  N IBLINE,IBTMP1,IBF
  1.  S IBTMP1="^TMP(""IBCNSJ53I"",$J,4,"_IB3553_")"
  1.  S VALMCNT=0,VALMBG=1,IBLINE=0
  1.  K @VALMAR
  1.  S IBF=$G(^TMP("IBCNSJ53I",$J,0))
  1.  I '+$P(IBF,U,2) D  Q
  1.  . S VALMCNT=2,@VALMAR@(1,0)=" "
  1.  . S @VALMAR@(2,0)=" ***Group Contains No Active Subscribers***"
  1.  ; go through the 4 level
  1.  D BPAS
  1.  Q
  1.  ;
  1. IS ; inactive subscriber entry
  1.  ;
  1.  N IBLINE,IBTMP1,IBF
  1.  S IBTMP1="^TMP(""IBCNSJ53I"",$J,5,"_IB3553_")"
  1.  S VALMCNT=0,VALMBG=1,IBLINE=0
  1.  K @VALMAR
  1.  S IBF=$G(^TMP("IBCNSJ53I",$J,0))
  1.  I '+$P(IBF,U,3) D  Q
  1.  . S VALMCNT=2,@VALMAR@(1,0)=" "
  1.  . S @VALMAR@(2,0)=" ***Group Contains No Inactive Subscribers***"
  1.  ; go through the 5 level
  1.  D BPAS
  1.  Q
  1.  ;