IBCNINSU ;AITC/TAZ - GENERAL INSURANCE UTILITIES ;8/20/20 12:46p.m.
;;2.0;INTEGRATED BILLING;**668,687,713,737,822**;21-MAR-94;Build 21
;;Per VA Directive 6402, this routine should not be modified.
;
PAYER(PIEN,APP,FLDS,FLGS,ARRAY) ;Payer Data Retrieval
;INPUT
; * = required input
; * PIEN - Payer IEN
; APP - EIV - Returns all fields for Payer Level and EIV level of file (overrides FLDS)
; - IIU - Returns all fields for Payer Level and IIU level of file (overrides FLDS)
; * FLDS - Required only if APP is null; If APP is populated this parameter is ignored
; - A single field number
; - A list of field numbers, separated by semicolons
; - A range of field numbers, in the form M:N, where M and N are the end points of the inclusive range.
; All field numbers within this range are retrieved.
; - * for all fields at the top level (no sub-multiple record).
; - ** for all fields including all fields and data in sub-multiple fields.
; - Field number of a multiple followed by an * to indicate all fields and records in the sub-multiple
; for that field.
; FLGS - E Returns External values in nodes ending with "E".
; - I Returns Internal values in nodes ending with "I".
; - NULL Returns External values.
; * ARRAY - Name of the Array that will contain the data (passed by reference)
;
;OUTPUT
; ARRAY - Data requested is returned in the array that was passed by reference
;
N APPIEN,APPIENI,IENS
I '$G(PIEN) S ARRAY(0)="Payer IEN is null or invalid" G PAYERX
I $G(APP)="",($G(FLDS)="") S ARRAY(0)="No fields requested." G PAYERX
S FLGS=$G(FLGS)
I $G(APP)'="" D G PAYERX
. S APPIEN=$$FIND1^DIC(365.13,,,APP) I 'APPIEN S ARRAY(0)="Invalid Application" Q
. S APPIENI=$O(^IBE(365.12,PIEN,1,"B",APPIEN,"")) ; Get the app's internal id for the current payer.
. ; Get all fields at Top Level
. S IENS=PIEN_",",FLDS="*"
. D GETS^DIQ(365.12,IENS,FLDS,FLGS,"ARRAY")
. ; Get all fields at Application Level
. S IENS=APPIENI_","_IENS,FLDS=".01:5.01" ;ignores the log data (history of the settings)
. D GETS^DIQ(365.121,IENS,FLDS,FLGS,"ARRAY")
S IENS=PIEN_","
D GETS^DIQ(365.12,IENS,FLDS,FLGS,"ARRAY")
;
PAYERX ; Exit subroutine
Q
;
PYRDEACT(PIEN) ;Check if payer is deactivated
;INPUT
; PIEN - Payer IEN
;OUTPUT
; DEACTIVATE - Payer Deactivated (Internal Format)
; 0 - No
; 1 - Yes
; DATE/TIME DEACTIVATE - Date and Time the Payer was deactivated (Internal Fileman Format)
;
N PYRARR,IENS
S IENS=PIEN_","
D PAYER(PIEN,,".07;.08","I",.PYRARR)
;
Q PYRARR(365.12,IENS,.07,"I")_U_PYRARR(365.12,IENS,.08,"I")
;
STOP() ; Determine if user wants to exit out of the whole option
; Init vars
N DIR,DIRUT,STOP,X,Y
;
W !
S DIR(0)="Y"
S DIR("A")="Do you want to exit out of this option entirely"
S DIR("B")="YES"
S DIR("?",1)=" Enter YES to immediately exit out of this option."
S DIR("?")=" Enter NO to return to the previous question."
D ^DIR K DIR
I $D(DIRUT) S (STOP,Y)=1 G STOPX
I 'Y S STOP=0
;
STOPX ; STOP exit pt
Q Y
;
FOREIGN(VALUE,PIECES,BLANK) ; check for ASCII chars outside (32-126 inclusive)
;INPUT:
; VALUE = the string/field to check
; PIECES = populate if a subcomponent has to be checked (defaults as 1)
; BLANK = populated if the value is to be cleared out if foreign char
; is encountered (1 tells program to clear out field if it cotains foreign)
;
; I VALUE had a character, in the pieces that were to be examined, that is
; outside of the ASCII range (32-126) a 1 is returned; otherwise returns ZERO
;
N BAD,DONE,IBI,IBY,PCE,STRNG,XX
S IBY="",BAD=0
I '$G(PIECES) S PIECES=1
F PCE=1:1:$L(PIECES,";") S XX=$P(PIECES,";",PCE) D
. S STRNG=$P(VALUE,HLECH,XX),DONE=0
. I STRNG'="" F IBI=1:1 S IBY=$E(STRNG,IBI) Q:IBY="" D Q:DONE
.. I $A(IBY)<32!($A(IBY)>126) D Q
... S (DONE,BAD)=1 ;Foreign character found
... I $G(BLANK) S $P(VALUE,HLECH,XX)=""
Q BAD
;
FILTER(STR,FLT) ; Filter Insurance Name, Group Name or Number
;IBFLT A^B^C
; A - 1 - Search for Name(s) that begin with
; the specified text (case insensitive)
; 2 - Search for Name(s) that contain
; the specified text (case insensitive)
; 3 - Search for Name(s) in a specified
; range (inclusive, case insensitive)
; 4 - Search for Name(s) that are blank (null)
; 5 - Filter by Selected Payer only (ONLY used by 'eIV Auto Update Report' (IBCNERPF)) ;IB*737/CKB
; B - Begin with text if A=1, Contains Text if A=2 or
; the range start if A=3
; C - Range End text (only present when A=3)
;OUTPUT:
; OK - 0 - Does not match Filter, do not include
; 1 - Matches Filter, include
;
N BEG,CHR,END,OK,TYPE,YY
S STR=$$UP^XLFSTR(STR)
S TYPE=$P(FLT,U,1)
S BEG=$$UP^XLFSTR($P(FLT,U,2))
S END=$$UP^XLFSTR($P(FLT,U,3))
S OK=0
;IB*737/CKB - added Payer (TYPE=5)
;Payer
I TYPE=5 S OK=1 G FILTERX
;Blank
I TYPE=4 D G FILTERX
. I STR="" S OK=1
;Test begins with
I TYPE=1 D G FILTERX
. I ($E(STR,1,$L(BEG))=BEG) S OK=1
;Test contains
I TYPE=2 D G FILTERX
. I (STR[BEG) S OK=1
;Test range
I TYPE=3 D G FILTERX
. N XX
. S XX=$E(STR,1,$L(BEG))
. I XX=BEG D Q
.. S YY=$E(STR,1,$L(END)) I YY]END Q
.. S OK=1 ;Matches begining characters of BEG - include
. I XX']BEG Q ;Preceeds Beg search
. S XX=$E(STR,1,$L(END))
. I XX=END S OK=1 Q ;Matches beginning characters of END - include
. I XX]END Q ;Follows End search
. S OK=1
FILTERX ; Exit
Q OK
;
VALIDDT(X) ; Check for validate date (internal form of the date) ;IB*737/CKB
; Input: X - internal date, FM format
; Returns: Y - if date if NOT valid, returns -1
; if the date is "" (null), returns a "" (null)
; if valid date, returns the internal date
N %DT,Y
Q:X="" ""
S %DT="X" D ^%DT
Q Y
; IB*822/DTG look up subscribers by plan for an Insurance
INSSUB(IBINS,IBRET,IBLER,IBPLNTYP,IBINSACT,IBPTACTV) ; IB*822/DTG look up subscribers by plan for an Insurance
;
; default, Insurance must be active
; Patient / Plans must be active
;
;
; IBINS - Insurance CO.
; IBRET - return array
; IBLER - error return
; IBPLNTYP - (optional) Plan Type (A) active, (I) inactive, (B) all (default is Active)
; IBINSACT - (optional) Insurance status (A) active, (I) inactive, (B) all (default is Active)
; IBPTACTV - (optional) Pt. Active (A) active, (I) inactive, (B) all (default is Active)
;
; IBRET return array layout
; IBRET(INS_INT) = Ins Co IEN ^ Insurance Company name ^ Street Address Line 1 ^ City ^ ST ^ ZIP ^ Status
; Plans will only be defined if there are patients in the plan for processing
;
; IBRET(INS_INT,PLAN_INT) = Plan IEN ^ Plan Group Number ^ Plan Group Name ^ group or indiv ^ Plan Active
; ^ Plan Inactive ^ Type of Plan PTR ^ Type of Plan name
;
; IBRET(INS_INT,PLAN_INT,PAT_DFN,PAT_FILE_INS_ENTRY-IEN)= 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 ^ FM DOB ^ FM eff dt
; ^ FM exp dt ^ FM current verified DT
;
K ^TMP("IBCNINSUL",$J)
N IBA,IBACT,IBB,IBDOB,IBEFFDT,IBEPT,IBEPTN,IBEXPDT,IBGNAM,IBGNUM,IBGOI,IBIA
N IBIB,IBIFO,IBIND,IBINSAC,IBNAM,IBPLN,IBPLNAT,IBPLNIT,IBPTAC,IBPTDA,IBPTDFN,IBPTHOLD
N IBPTIC,IBPTINS,IBPTPLAN,IBTOP,IBTOPN,IBVERDT,IBVERUSR,X,XX
S IBINS=$G(IBINS),IBRET=$G(IBRET),IBLER=$G(IBLER),IBPLNTYP=$G(IBPLNTYP)
S IBINSACT=$G(IBINSACT),IBPTACTV=$G(IBPTACTV)
S IBINSACT=$S(IBINSACT="A":1,IBINSACT="I":2,IBINSACT="B":3,1:"1")
S IBPLNTYP=$S(IBPLNTYP="A":1,IBPLNTYP="I":2,IBPLNTYP="B":3,1:"1")
S IBPTACTV=$S(IBPTACTV="A":1,IBPTACTV="I":2,IBPTACTV="B":3,1:"1")
;
I 'IBINS D IER("Missing Insurance") G INSSUBQ
I IBRET="" D IER("Missing Return") G INSSUBQ
K @IBRET
; get ins info
K IBIA,IBIB D GETS^DIQ(36,IBINS_",",".01;.05;.111;.114;.115;.116","I","IBIA")
I $G(IBIA(36,IBINS_",",.01,"I"))="" D IER("Insurance Not Found") G INSSUBQ ; insurance must have a name
M IBIB=IBIA(36,IBINS_",")
; is insurance active
S IBINSAC=+$G(IBIB(.05,"I")) ; +.05=0 - Active, +.05=1 - Inactive
I IBINSAC=1&(IBINSACT'=2&(IBINSACT'=3)) D IER("Insurance is inactive, Only want active Insurances") G INSSUBQ
I IBINSAC'=1&(IBINSACT'=1&(IBINSACT'=3)) D IER("Insurance is active, Only want inactive Insurances") G INSSUBQ
;
; Ins Co IEN ^ Insurance Company name ^ Street Address Line 1 ^ City ^ ST ^ ZIP ^ Status
S IBIFO=IBINS_U_$E($G(IBIB(.01,"I")),1,30)_U_$G(IBIB(.111,"I"))_U_$G(IBIB(.114,"I"))
S X=$G(IBIB(.115,"I")),XX=$S(X:$$GET1^DIQ(5,X_",",1,"I"),1:"")
S IBIFO=IBIFO_U_XX_U_$E($G(IBIB(.116,"I")),1,5)_U_IBINSAC
S ^TMP("IBCNINSUL",$J,"OUT",IBINS)=IBIFO
;
; get the plans
K ^TMP("IBCNINSUL",$J,"PLAN")
S IBPLN=0 F S IBPLN=$O(^IBA(355.3,"B",IBINS,IBPLN)) Q:'IBPLN D
. K IBIA,IBIB D GETS^DIQ(355.3,IBPLN_",",".01;.02;.09;.11;.15;2.02;2.01","IE","IBIA")
. M IBIB=IBIA(355.3,IBPLN_",")
. I $G(IBIB(.01,"I"))'=IBINS Q ; This plan is not associated to the insurance at the data level.
. S IBGOI=$G(IBIB(.02,"I")) ; Group or Individual Plan
. S IBACT=$G(IBIB(.11,"I")),(IBPLNAT,IBPLNIT)="" ; +IBACT=0 - Active, +IBACT=1 - Inactive
. I '+IBACT S IBPLNAT=1 ; plan active
. I +IBACT S IBPLNIT=1 ; plan inactive
. S IBGNUM=$G(IBIB(2.02,"I")) S:IBGNUM="" IBGNUM="<NO GROUP NUMBER>"
. S IBGNAM=$G(IBIB(2.01,"I")) S:IBGNAM="" IBGNAM="<NO GROUP NAME>"
. S IBEPT=$G(IBIB(.15,"I")) ; Electronic Plan Type code
. S IBEPTN=$G(IBIB(.15,"E")) ; Electronic Plan Type description
. S IBTOP=$G(IBIB(.09,"I")) ; Type of Plan
. S IBTOPN=$G(IBIB(.09,"I")) ; Type of Plan Name from 355.1
. ; Plan IEN ^ Plan Group Number ^ Plan Group Name ^ group or indiv ^ Plan Active ^ Plan Inactive ^ Type of Plan PTR ^ Type of Plan name
. S ^TMP("IBCNINSUL",$J,"PLAN",(IBACT+1),IBPLN)=IBPLN_U_IBGNUM_U_IBGNAM_U_IBGOI_U_IBPLNAT_U_IBPLNIT_U_IBTOP_U_IBTOPN ; break out plans by active (1) and inactive (2)
. S ^TMP("IBCNINSUL",$J,"PLAN",3,IBPLN)=IBPLN_U_IBGNUM_U_IBGNAM_U_IBGOI_U_IBPLNAT_U_IBPLNIT_U_IBTOP_U_IBTOPN ; all plans
;
; collect the patients
;
S IBPTDFN=0
F S IBPTDFN=$O(^DPT("AB",IBINS,IBPTDFN)) Q:'IBPTDFN S IBPTINS=0 D
. F S IBPTINS=$O(^DPT("AB",IBINS,IBPTDFN,IBPTINS)) Q:'IBPTINS D
.. S IBPTDA=IBPTINS_","_IBPTDFN_","
.. S IBPTPLAN=$$GET1^DIQ(2.312,IBPTDA,.18,"I")
.. I IBPTPLAN="" Q ; if no plan
.. I $D(^TMP("IBCNINSUL",$J,"PLAN",IBPLNTYP,IBPTPLAN)) D
... ;get status
... S IBIND=$$ZND^IBCNS1(IBPTDFN,IBPTINS)
... 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=$$DTC5(IBDOB) ; Patient's DOB
... S $P(IBPTHOLD,"^",3)=XX,$P(IBPTHOLD,U,11)=IBDOB
... ;
... 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=$$DTC5(IBEFFDT) ; Effective Date
... S $P(IBPTHOLD,"^",5)=XX,$P(IBPTHOLD,U,12)=IBEFFDT
... ;
... S IBEXPDT=$P(IBIND,"^",4),XX=$$DTC5(IBEXPDT) ; Expiration Date
... S $P(IBPTHOLD,"^",6)=XX,$P(IBPTHOLD,"^",13)=IBEXPDT
... ;
... ; 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
... ;
... S IBVERDT=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",1.03,"I") ; Verified Date
... S $P(IBPTHOLD,"^",14)=IBVERDT
... S IBVERUSR=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",1.04,"I") ; Verified User
... ;
... ; 1 - Patient's Name (22 chars) ^
... ; 2 - Patient's SSN ^
... ; 3 - Patient's DOB ^
... ; 4 - Subscriber ID (20 chars max) ^
... ; 5 - Effective Date ^
... ; 6 - Expiration Date ^
... ; 7 - Whose Insurance? ^
... ; 8 - Patient ID ^
... ; 9 - ACTIVE ^
... ; 10 - INACTIVE ^
... ; 11 - FM DOB ^
... ; 12 - FM eff dt ^
... ; 13 - FM exp dt ^
... ; 14 - FM current verified DT
... ;
... ;active or inactive
... ;
... S (IBPTAC,IBPTIC)=0 D S $P(IBPTHOLD,U,9)=IBPTAC,$P(IBPTHOLD,U,10)=IBPTIC
... . ;
... . I 'IBEFFDT!($P(IBPTHOLD,U,5)="") S IBPTIC=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 IBPTIC=1 Q ; if the expiration date is less than today count inactive
... .. ;
... .. S IBPTAC=1 ; otherwise count active
... . ;
... . I (IBEFFDT&($P(IBPTHOLD,U,5)'="")&(IBEFFDT>DT)) S IBPTIC=1 Q ; if a valid effective date and the date is greater than today count inactive
... . ;
... . S IBPTAC=1 ; otherwise count active
... . ;
... ; if pt policy is not active skip
... I IBPTAC'=1&(IBPTACTV'=2&(IBPTACTV'=3)) Q
... I IBPTAC=1&(IBPTACTV'=1&(IBPTACTV'=3)) Q
... ;
... I $G(^TMP("IBCNINSUL",$J,"OUT",IBINS,IBPTPLAN))="" D ; make sure that plan info is returned
... . S ^TMP("IBCNINSUL",$J,"OUT",IBINS,IBPTPLAN)=$G(^TMP("IBCNINSUL",$J,"PLAN",IBPLNTYP,IBPTPLAN))
... . ;
... S ^TMP("IBCNINSUL",$J,"OUT",IBINS,IBPTPLAN,IBPTDFN,IBPTINS)=IBPTHOLD
;
INSSUBQ ; exit point for ins, plan, subscriber collect
;
K @IBRET M @IBRET=^TMP("IBCNINSUL",$J,"OUT")
;
; clean up temp file
K ^TMP("IBCNINSUL",$J)
Q
;
;
DTC5(IBDTCK) ; check date return external with 4 digit year if valid
;
N IBDT,IBBK S IBDT=""
I 'IBDTCK G DTCO
S IBDT=$$FMTE^XLFDT(IBDTCK,"5DZ")
;
G DTCO
;
DTCO ; date check exit
;
Q IBDT
;
IER(IBMS) ; set error return
;
I IBMS="" Q
I IBLER="" Q
S @IBLER=IBMS
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNINSU 14734 printed Mar 25, 2026@15:40:47 Page 2
IBCNINSU ;AITC/TAZ - GENERAL INSURANCE UTILITIES ;8/20/20 12:46p.m.
+1 ;;2.0;INTEGRATED BILLING;**668,687,713,737,822**;21-MAR-94;Build 21
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
PAYER(PIEN,APP,FLDS,FLGS,ARRAY) ;Payer Data Retrieval
+1 ;INPUT
+2 ; * = required input
+3 ; * PIEN - Payer IEN
+4 ; APP - EIV - Returns all fields for Payer Level and EIV level of file (overrides FLDS)
+5 ; - IIU - Returns all fields for Payer Level and IIU level of file (overrides FLDS)
+6 ; * FLDS - Required only if APP is null; If APP is populated this parameter is ignored
+7 ; - A single field number
+8 ; - A list of field numbers, separated by semicolons
+9 ; - A range of field numbers, in the form M:N, where M and N are the end points of the inclusive range.
+10 ; All field numbers within this range are retrieved.
+11 ; - * for all fields at the top level (no sub-multiple record).
+12 ; - ** for all fields including all fields and data in sub-multiple fields.
+13 ; - Field number of a multiple followed by an * to indicate all fields and records in the sub-multiple
+14 ; for that field.
+15 ; FLGS - E Returns External values in nodes ending with "E".
+16 ; - I Returns Internal values in nodes ending with "I".
+17 ; - NULL Returns External values.
+18 ; * ARRAY - Name of the Array that will contain the data (passed by reference)
+19 ;
+20 ;OUTPUT
+21 ; ARRAY - Data requested is returned in the array that was passed by reference
+22 ;
+23 NEW APPIEN,APPIENI,IENS
+24 IF '$GET(PIEN)
SET ARRAY(0)="Payer IEN is null or invalid"
GOTO PAYERX
+25 IF $GET(APP)=""
IF ($GET(FLDS)="")
SET ARRAY(0)="No fields requested."
GOTO PAYERX
+26 SET FLGS=$GET(FLGS)
+27 IF $GET(APP)'=""
Begin DoDot:1
+28 SET APPIEN=$$FIND1^DIC(365.13,,,APP)
IF 'APPIEN
SET ARRAY(0)="Invalid Application"
QUIT
+29 ; Get the app's internal id for the current payer.
SET APPIENI=$ORDER(^IBE(365.12,PIEN,1,"B",APPIEN,""))
+30 ; Get all fields at Top Level
+31 SET IENS=PIEN_","
SET FLDS="*"
+32 DO GETS^DIQ(365.12,IENS,FLDS,FLGS,"ARRAY")
+33 ; Get all fields at Application Level
+34 ;ignores the log data (history of the settings)
SET IENS=APPIENI_","_IENS
SET FLDS=".01:5.01"
+35 DO GETS^DIQ(365.121,IENS,FLDS,FLGS,"ARRAY")
End DoDot:1
GOTO PAYERX
+36 SET IENS=PIEN_","
+37 DO GETS^DIQ(365.12,IENS,FLDS,FLGS,"ARRAY")
+38 ;
PAYERX ; Exit subroutine
+1 QUIT
+2 ;
PYRDEACT(PIEN) ;Check if payer is deactivated
+1 ;INPUT
+2 ; PIEN - Payer IEN
+3 ;OUTPUT
+4 ; DEACTIVATE - Payer Deactivated (Internal Format)
+5 ; 0 - No
+6 ; 1 - Yes
+7 ; DATE/TIME DEACTIVATE - Date and Time the Payer was deactivated (Internal Fileman Format)
+8 ;
+9 NEW PYRARR,IENS
+10 SET IENS=PIEN_","
+11 DO PAYER(PIEN,,".07;.08","I",.PYRARR)
+12 ;
+13 QUIT PYRARR(365.12,IENS,.07,"I")_U_PYRARR(365.12,IENS,.08,"I")
+14 ;
STOP() ; Determine if user wants to exit out of the whole option
+1 ; Init vars
+2 NEW DIR,DIRUT,STOP,X,Y
+3 ;
+4 WRITE !
+5 SET DIR(0)="Y"
+6 SET DIR("A")="Do you want to exit out of this option entirely"
+7 SET DIR("B")="YES"
+8 SET DIR("?",1)=" Enter YES to immediately exit out of this option."
+9 SET DIR("?")=" Enter NO to return to the previous question."
+10 DO ^DIR
KILL DIR
+11 IF $DATA(DIRUT)
SET (STOP,Y)=1
GOTO STOPX
+12 IF 'Y
SET STOP=0
+13 ;
STOPX ; STOP exit pt
+1 QUIT Y
+2 ;
FOREIGN(VALUE,PIECES,BLANK) ; check for ASCII chars outside (32-126 inclusive)
+1 ;INPUT:
+2 ; VALUE = the string/field to check
+3 ; PIECES = populate if a subcomponent has to be checked (defaults as 1)
+4 ; BLANK = populated if the value is to be cleared out if foreign char
+5 ; is encountered (1 tells program to clear out field if it cotains foreign)
+6 ;
+7 ; I VALUE had a character, in the pieces that were to be examined, that is
+8 ; outside of the ASCII range (32-126) a 1 is returned; otherwise returns ZERO
+9 ;
+10 NEW BAD,DONE,IBI,IBY,PCE,STRNG,XX
+11 SET IBY=""
SET BAD=0
+12 IF '$GET(PIECES)
SET PIECES=1
+13 FOR PCE=1:1:$LENGTH(PIECES,";")
SET XX=$PIECE(PIECES,";",PCE)
Begin DoDot:1
+14 SET STRNG=$PIECE(VALUE,HLECH,XX)
SET DONE=0
+15 IF STRNG'=""
FOR IBI=1:1
SET IBY=$EXTRACT(STRNG,IBI)
if IBY=""
QUIT
Begin DoDot:2
+16 IF $ASCII(IBY)<32!($ASCII(IBY)>126)
Begin DoDot:3
+17 ;Foreign character found
SET (DONE,BAD)=1
+18 IF $GET(BLANK)
SET $PIECE(VALUE,HLECH,XX)=""
End DoDot:3
QUIT
End DoDot:2
if DONE
QUIT
End DoDot:1
+19 QUIT BAD
+20 ;
FILTER(STR,FLT) ; Filter Insurance Name, Group Name or Number
+1 ;IBFLT A^B^C
+2 ; A - 1 - Search for Name(s) that begin with
+3 ; the specified text (case insensitive)
+4 ; 2 - Search for Name(s) that contain
+5 ; the specified text (case insensitive)
+6 ; 3 - Search for Name(s) in a specified
+7 ; range (inclusive, case insensitive)
+8 ; 4 - Search for Name(s) that are blank (null)
+9 ; 5 - Filter by Selected Payer only (ONLY used by 'eIV Auto Update Report' (IBCNERPF)) ;IB*737/CKB
+10 ; B - Begin with text if A=1, Contains Text if A=2 or
+11 ; the range start if A=3
+12 ; C - Range End text (only present when A=3)
+13 ;OUTPUT:
+14 ; OK - 0 - Does not match Filter, do not include
+15 ; 1 - Matches Filter, include
+16 ;
+17 NEW BEG,CHR,END,OK,TYPE,YY
+18 SET STR=$$UP^XLFSTR(STR)
+19 SET TYPE=$PIECE(FLT,U,1)
+20 SET BEG=$$UP^XLFSTR($PIECE(FLT,U,2))
+21 SET END=$$UP^XLFSTR($PIECE(FLT,U,3))
+22 SET OK=0
+23 ;IB*737/CKB - added Payer (TYPE=5)
+24 ;Payer
+25 IF TYPE=5
SET OK=1
GOTO FILTERX
+26 ;Blank
+27 IF TYPE=4
Begin DoDot:1
+28 IF STR=""
SET OK=1
End DoDot:1
GOTO FILTERX
+29 ;Test begins with
+30 IF TYPE=1
Begin DoDot:1
+31 IF ($EXTRACT(STR,1,$LENGTH(BEG))=BEG)
SET OK=1
End DoDot:1
GOTO FILTERX
+32 ;Test contains
+33 IF TYPE=2
Begin DoDot:1
+34 IF (STR[BEG)
SET OK=1
End DoDot:1
GOTO FILTERX
+35 ;Test range
+36 IF TYPE=3
Begin DoDot:1
+37 NEW XX
+38 SET XX=$EXTRACT(STR,1,$LENGTH(BEG))
+39 IF XX=BEG
Begin DoDot:2
+40 SET YY=$EXTRACT(STR,1,$LENGTH(END))
IF YY]END
QUIT
+41 ;Matches begining characters of BEG - include
SET OK=1
End DoDot:2
QUIT
+42 ;Preceeds Beg search
IF XX']BEG
QUIT
+43 SET XX=$EXTRACT(STR,1,$LENGTH(END))
+44 ;Matches beginning characters of END - include
IF XX=END
SET OK=1
QUIT
+45 ;Follows End search
IF XX]END
QUIT
+46 SET OK=1
End DoDot:1
GOTO FILTERX
FILTERX ; Exit
+1 QUIT OK
+2 ;
VALIDDT(X) ; Check for validate date (internal form of the date) ;IB*737/CKB
+1 ; Input: X - internal date, FM format
+2 ; Returns: Y - if date if NOT valid, returns -1
+3 ; if the date is "" (null), returns a "" (null)
+4 ; if valid date, returns the internal date
+5 NEW %DT,Y
+6 if X=""
QUIT ""
+7 SET %DT="X"
DO ^%DT
+8 QUIT Y
+9 ; IB*822/DTG look up subscribers by plan for an Insurance
INSSUB(IBINS,IBRET,IBLER,IBPLNTYP,IBINSACT,IBPTACTV) ; IB*822/DTG look up subscribers by plan for an Insurance
+1 ;
+2 ; default, Insurance must be active
+3 ; Patient / Plans must be active
+4 ;
+5 ;
+6 ; IBINS - Insurance CO.
+7 ; IBRET - return array
+8 ; IBLER - error return
+9 ; IBPLNTYP - (optional) Plan Type (A) active, (I) inactive, (B) all (default is Active)
+10 ; IBINSACT - (optional) Insurance status (A) active, (I) inactive, (B) all (default is Active)
+11 ; IBPTACTV - (optional) Pt. Active (A) active, (I) inactive, (B) all (default is Active)
+12 ;
+13 ; IBRET return array layout
+14 ; IBRET(INS_INT) = Ins Co IEN ^ Insurance Company name ^ Street Address Line 1 ^ City ^ ST ^ ZIP ^ Status
+15 ; Plans will only be defined if there are patients in the plan for processing
+16 ;
+17 ; IBRET(INS_INT,PLAN_INT) = Plan IEN ^ Plan Group Number ^ Plan Group Name ^ group or indiv ^ Plan Active
+18 ; ^ Plan Inactive ^ Type of Plan PTR ^ Type of Plan name
+19 ;
+20 ; IBRET(INS_INT,PLAN_INT,PAT_DFN,PAT_FILE_INS_ENTRY-IEN)= Patient's Name (22 chars) ^ Patient's SSN ^ Patient's DOB
+21 ; ^ Subscriber ID (20 chars max) ^ Effective Date
+22 ; ^ Expiration Date ^ Whose Insurance?
+23 ; ^ Patient ID ^ ACTIVE ^ INACTIVE ^ FM DOB ^ FM eff dt
+24 ; ^ FM exp dt ^ FM current verified DT
+25 ;
+26 KILL ^TMP("IBCNINSUL",$JOB)
+27 NEW IBA,IBACT,IBB,IBDOB,IBEFFDT,IBEPT,IBEPTN,IBEXPDT,IBGNAM,IBGNUM,IBGOI,IBIA
+28 NEW IBIB,IBIFO,IBIND,IBINSAC,IBNAM,IBPLN,IBPLNAT,IBPLNIT,IBPTAC,IBPTDA,IBPTDFN,IBPTHOLD
+29 NEW IBPTIC,IBPTINS,IBPTPLAN,IBTOP,IBTOPN,IBVERDT,IBVERUSR,X,XX
+30 SET IBINS=$GET(IBINS)
SET IBRET=$GET(IBRET)
SET IBLER=$GET(IBLER)
SET IBPLNTYP=$GET(IBPLNTYP)
+31 SET IBINSACT=$GET(IBINSACT)
SET IBPTACTV=$GET(IBPTACTV)
+32 SET IBINSACT=$SELECT(IBINSACT="A":1,IBINSACT="I":2,IBINSACT="B":3,1:"1")
+33 SET IBPLNTYP=$SELECT(IBPLNTYP="A":1,IBPLNTYP="I":2,IBPLNTYP="B":3,1:"1")
+34 SET IBPTACTV=$SELECT(IBPTACTV="A":1,IBPTACTV="I":2,IBPTACTV="B":3,1:"1")
+35 ;
+36 IF 'IBINS
DO IER("Missing Insurance")
GOTO INSSUBQ
+37 IF IBRET=""
DO IER("Missing Return")
GOTO INSSUBQ
+38 KILL @IBRET
+39 ; get ins info
+40 KILL IBIA,IBIB
DO GETS^DIQ(36,IBINS_",",".01;.05;.111;.114;.115;.116","I","IBIA")
+41 ; insurance must have a name
IF $GET(IBIA(36,IBINS_",",.01,"I"))=""
DO IER("Insurance Not Found")
GOTO INSSUBQ
+42 MERGE IBIB=IBIA(36,IBINS_",")
+43 ; is insurance active
+44 ; +.05=0 - Active, +.05=1 - Inactive
SET IBINSAC=+$GET(IBIB(.05,"I"))
+45 IF IBINSAC=1&(IBINSACT'=2&(IBINSACT'=3))
DO IER("Insurance is inactive, Only want active Insurances")
GOTO INSSUBQ
+46 IF IBINSAC'=1&(IBINSACT'=1&(IBINSACT'=3))
DO IER("Insurance is active, Only want inactive Insurances")
GOTO INSSUBQ
+47 ;
+48 ; Ins Co IEN ^ Insurance Company name ^ Street Address Line 1 ^ City ^ ST ^ ZIP ^ Status
+49 SET IBIFO=IBINS_U_$EXTRACT($GET(IBIB(.01,"I")),1,30)_U_$GET(IBIB(.111,"I"))_U_$GET(IBIB(.114,"I"))
+50 SET X=$GET(IBIB(.115,"I"))
SET XX=$SELECT(X:$$GET1^DIQ(5,X_",",1,"I"),1:"")
+51 SET IBIFO=IBIFO_U_XX_U_$EXTRACT($GET(IBIB(.116,"I")),1,5)_U_IBINSAC
+52 SET ^TMP("IBCNINSUL",$JOB,"OUT",IBINS)=IBIFO
+53 ;
+54 ; get the plans
+55 KILL ^TMP("IBCNINSUL",$JOB,"PLAN")
+56 SET IBPLN=0
FOR
SET IBPLN=$ORDER(^IBA(355.3,"B",IBINS,IBPLN))
if 'IBPLN
QUIT
Begin DoDot:1
+57 KILL IBIA,IBIB
DO GETS^DIQ(355.3,IBPLN_",",".01;.02;.09;.11;.15;2.02;2.01","IE","IBIA")
+58 MERGE IBIB=IBIA(355.3,IBPLN_",")
+59 ; This plan is not associated to the insurance at the data level.
IF $GET(IBIB(.01,"I"))'=IBINS
QUIT
+60 ; Group or Individual Plan
SET IBGOI=$GET(IBIB(.02,"I"))
+61 ; +IBACT=0 - Active, +IBACT=1 - Inactive
SET IBACT=$GET(IBIB(.11,"I"))
SET (IBPLNAT,IBPLNIT)=""
+62 ; plan active
IF '+IBACT
SET IBPLNAT=1
+63 ; plan inactive
IF +IBACT
SET IBPLNIT=1
+64 SET IBGNUM=$GET(IBIB(2.02,"I"))
if IBGNUM=""
SET IBGNUM="<NO GROUP NUMBER>"
+65 SET IBGNAM=$GET(IBIB(2.01,"I"))
if IBGNAM=""
SET IBGNAM="<NO GROUP NAME>"
+66 ; Electronic Plan Type code
SET IBEPT=$GET(IBIB(.15,"I"))
+67 ; Electronic Plan Type description
SET IBEPTN=$GET(IBIB(.15,"E"))
+68 ; Type of Plan
SET IBTOP=$GET(IBIB(.09,"I"))
+69 ; Type of Plan Name from 355.1
SET IBTOPN=$GET(IBIB(.09,"I"))
+70 ; Plan IEN ^ Plan Group Number ^ Plan Group Name ^ group or indiv ^ Plan Active ^ Plan Inactive ^ Type of Plan PTR ^ Type of Plan name
+71 ; break out plans by active (1) and inactive (2)
SET ^TMP("IBCNINSUL",$JOB,"PLAN",(IBACT+1),IBPLN)=IBPLN_U_IBGNUM_U_IBGNAM_U_IBGOI_U_IBPLNAT_U_IBPLNIT_U_IBTOP_U_IBTOPN
+72 ; all plans
SET ^TMP("IBCNINSUL",$JOB,"PLAN",3,IBPLN)=IBPLN_U_IBGNUM_U_IBGNAM_U_IBGOI_U_IBPLNAT_U_IBPLNIT_U_IBTOP_U_IBTOPN
End DoDot:1
+73 ;
+74 ; collect the patients
+75 ;
+76 SET IBPTDFN=0
+77 FOR
SET IBPTDFN=$ORDER(^DPT("AB",IBINS,IBPTDFN))
if 'IBPTDFN
QUIT
SET IBPTINS=0
Begin DoDot:1
+78 FOR
SET IBPTINS=$ORDER(^DPT("AB",IBINS,IBPTDFN,IBPTINS))
if 'IBPTINS
QUIT
Begin DoDot:2
+79 SET IBPTDA=IBPTINS_","_IBPTDFN_","
+80 SET IBPTPLAN=$$GET1^DIQ(2.312,IBPTDA,.18,"I")
+81 ; if no plan
IF IBPTPLAN=""
QUIT
+82 IF $DATA(^TMP("IBCNINSUL",$JOB,"PLAN",IBPLNTYP,IBPTPLAN))
Begin DoDot:3
+83 ;get status
+84 SET IBIND=$$ZND^IBCNS1(IBPTDFN,IBPTINS)
+85 SET X=$$PT^IBEFUNC(IBPTDFN)
+86 ; Patient's Name (22 chars)
SET IBNAM=$EXTRACT($PIECE(X,"^",1),1,22)
+87 if IBNAM=""
SET IBNAM="<Pt. "_IBPTDFN_" Name Missing>"
+88 SET IBPTHOLD=IBNAM
+89 ;
+90 ; Retrieve last 4 of SSN (last 5 if pseudo SSN)
+91 ; Patient's SSN
SET XX=$$GET1^DIQ(2,IBPTDFN_",",.09,"I")
+92 SET XX=$SELECT($EXTRACT(XX,$LENGTH(XX))="P":$EXTRACT(XX,$LENGTH(XX)-4,$LENGTH(XX)),1:$EXTRACT(XX,$LENGTH(XX)-3,$LENGTH(XX)))
+93 SET $PIECE(IBPTHOLD,"^",2)=XX
+94 ;
+95 ; Patient's DOB
SET IBDOB=$$GET1^DIQ(2,IBPTDFN_",",.03,"I")
SET XX=$$DTC5(IBDOB)
+96 SET $PIECE(IBPTHOLD,"^",3)=XX
SET $PIECE(IBPTHOLD,U,11)=IBDOB
+97 ;
+98 SET XX=$PIECE(IBIND,"^",2)
SET XX=$SELECT(XX'="":XX,1:"<NO SUBS ID>")
+99 ; Subscriber ID (20 chars max)
SET $PIECE(IBPTHOLD,"^",4)=XX
+100 ;
+101 ; Effective Date
SET IBEFFDT=$PIECE(IBIND,"^",8)
SET XX=$$DTC5(IBEFFDT)
+102 SET $PIECE(IBPTHOLD,"^",5)=XX
SET $PIECE(IBPTHOLD,U,12)=IBEFFDT
+103 ;
+104 ; Expiration Date
SET IBEXPDT=$PIECE(IBIND,"^",4)
SET XX=$$DTC5(IBEXPDT)
+105 SET $PIECE(IBPTHOLD,"^",6)=XX
SET $PIECE(IBPTHOLD,"^",13)=IBEXPDT
+106 ;
+107 ; Whose Insurance?
+108 SET XX=$PIECE(IBIND,"^",6)
SET XX=$SELECT(XX="v":"VET",XX="s":"SPO",XX="o":"OTH",1:"UNK")
+109 SET $PIECE(IBPTHOLD,"^",7)=XX
+110 ; Patient ID
SET XX=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",5.01,"I")
+111 SET $PIECE(IBPTHOLD,"^",8)=XX
+112 ;
+113 ; Verified Date
SET IBVERDT=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",1.03,"I")
+114 SET $PIECE(IBPTHOLD,"^",14)=IBVERDT
+115 ; Verified User
SET IBVERUSR=$$GET1^DIQ(2.312,IBPTINS_","_IBPTDFN_",",1.04,"I")
+116 ;
+117 ; 1 - Patient's Name (22 chars) ^
+118 ; 2 - Patient's SSN ^
+119 ; 3 - Patient's DOB ^
+120 ; 4 - Subscriber ID (20 chars max) ^
+121 ; 5 - Effective Date ^
+122 ; 6 - Expiration Date ^
+123 ; 7 - Whose Insurance? ^
+124 ; 8 - Patient ID ^
+125 ; 9 - ACTIVE ^
+126 ; 10 - INACTIVE ^
+127 ; 11 - FM DOB ^
+128 ; 12 - FM eff dt ^
+129 ; 13 - FM exp dt ^
+130 ; 14 - FM current verified DT
+131 ;
+132 ;active or inactive
+133 ;
+134 SET (IBPTAC,IBPTIC)=0
Begin DoDot:4
+135 ;
+136 ; if not a valid effective date count inactive
IF 'IBEFFDT!($PIECE(IBPTHOLD,U,5)="")
SET IBPTIC=1
QUIT
+137 ;
+138 ; if there is a valid expiration date
IF (IBEXPDT'=""&($PIECE(IBPTHOLD,U,6)'=""))
Begin DoDot:5
+139 ;
+140 ; if the expiration date is less than today count inactive
IF IBEXPDT<DT
SET IBPTIC=1
QUIT
+141 ;
+142 ; otherwise count active
SET IBPTAC=1
End DoDot:5
QUIT
+143 ;
+144 ; if a valid effective date and the date is greater than today count inactive
IF (IBEFFDT&($PIECE(IBPTHOLD,U,5)'="")&(IBEFFDT>DT))
SET IBPTIC=1
QUIT
+145 ;
+146 ; otherwise count active
SET IBPTAC=1
+147 ;
End DoDot:4
SET $PIECE(IBPTHOLD,U,9)=IBPTAC
SET $PIECE(IBPTHOLD,U,10)=IBPTIC
+148 ; if pt policy is not active skip
+149 IF IBPTAC'=1&(IBPTACTV'=2&(IBPTACTV'=3))
QUIT
+150 IF IBPTAC=1&(IBPTACTV'=1&(IBPTACTV'=3))
QUIT
+151 ;
+152 ; make sure that plan info is returned
IF $GET(^TMP("IBCNINSUL",$JOB,"OUT",IBINS,IBPTPLAN))=""
Begin DoDot:4
+153 SET ^TMP("IBCNINSUL",$JOB,"OUT",IBINS,IBPTPLAN)=$GET(^TMP("IBCNINSUL",$JOB,"PLAN",IBPLNTYP,IBPTPLAN))
+154 ;
End DoDot:4
+155 SET ^TMP("IBCNINSUL",$JOB,"OUT",IBINS,IBPTPLAN,IBPTDFN,IBPTINS)=IBPTHOLD
End DoDot:3
End DoDot:2
End DoDot:1
+156 ;
INSSUBQ ; exit point for ins, plan, subscriber collect
+1 ;
+2 KILL @IBRET
MERGE @IBRET=^TMP("IBCNINSUL",$JOB,"OUT")
+3 ;
+4 ; clean up temp file
+5 KILL ^TMP("IBCNINSUL",$JOB)
+6 QUIT
+7 ;
+8 ;
DTC5(IBDTCK) ; check date return external with 4 digit year if valid
+1 ;
+2 NEW IBDT,IBBK
SET IBDT=""
+3 IF 'IBDTCK
GOTO DTCO
+4 SET IBDT=$$FMTE^XLFDT(IBDTCK,"5DZ")
+5 ;
+6 GOTO DTCO
+7 ;
DTCO ; date check exit
+1 ;
+2 QUIT IBDT
+3 ;
IER(IBMS) ; set error return
+1 ;
+2 IF IBMS=""
QUIT
+3 IF IBLER=""
QUIT
+4 SET @IBLER=IBMS
+5 QUIT
+6 ;
