IBCNSP1 ;ALB/AAS - INSURANCE MANAGEMENT - policy actions ;05-MAY-2015
;;2.0;INTEGRATED BILLING;**6,28,40,43,52,85,103,361,371,377,497,549**;21-MAR-94;Build 54
;;Per VA Directive 6402, this routine should not be modified.
;;ICR#5002 for read of ^DIE input template data
;
% G EN^IBCNSP
;
EA ; -- Edit all
N IBCDFN,IBTRC,IBTRN
D FULL^VALM1
;
;IB*2.0*549 - Added Security Key check
I '$D(^XUSEC("IB GROUP PLAN EDIT",DUZ)) D Q
. W !!,*7,"Sorry, but you do not have the required privileges to Edit All"
. K DIR
. D PAUSE^VALM1
. D EAQ
;
W !!
S IBCDFN=$P($G(IBPPOL),"^",4)
I 'IBCDFN W !!,"Can't identify the policy!" G EAQ
S IBCNSEH=1 D PAT^IBCNSEH
;
D BEFORE^IBCNSEVT
D PATPOL^IBCNSM32(IBCDFN)
D AFTER^IBCNSEVT,^IBCNSEVT
;
; -- edit policy data
D POL^IBCNSEH
D EDPOL^IBCNSM3(IBCDFN)
;
W !!
D AI
;
EAQ ; Edit All Exit
D:$G(IBTRC) AIP^IBCNSP02(IBTRC)
D BLD^IBCNSP
S VALMBCK="R"
Q
;
AB ; -- Annual Benefits
;
; IB*2.0*549 - Added Security Key check
I '$D(^XUSEC("IB GROUP PLAN EDIT",DUZ)) D Q
. W !!,*7,"Sorry, but you do not have the required privileges to edit Annual Benefits."
. K DIR
. D PAUSE^VALM1
. S VALMBCK="R"
;
S X=+$P($G(IBPPOL),"^",4),IBCNS=+$G(^DPT(DFN,.312,X,0)),IBCPOL=+$P($G(^(0)),"^",18)
I 'IBCPOL W !!,"Can't identify the plan!" S VALMBCK="" G ABQ
D FULL^VALM1 W !!
D EN^VALM("IBCNS ANNUAL BENEFITS")
S VALMBCK="R"
ABQ Q
;
BU ; -- Benefits Used
S IBCDFN=+$P($G(IBPPOL),"^",4),IBCNS=+$G(^DPT(DFN,.312,IBCDFN,0)),IBCPOL=+$P($G(^(0)),"^",18)
I 'IBCPOL W !!,"Can't identify the plan!" S VALMBCK="" G BUQ
D FULL^VALM1 W !!
D EN^VALM("IBCNS BENEFITS USED BY DATE")
S VALMBCK="R"
BUQ Q
;
IT ; -- edit insurance type info from patient policy and plan edit
D FULL^VALM1
;
;IB*2.0*549 - Added Security Key check
I '$D(^XUSEC("IB GROUP PLAN EDIT",DUZ)) D Q
. W !!,*7,"Sorry, but you do not have the required privileges to edit Insurance Type"
. W !,"Information."
. K DIR
. D PAUSE^VALM1
. D ITQ
;
W !!
N IBCDFN
S IBCDFN=+$P($G(IBPPOL),"^",4),IBCPOL=+$P($G(^DPT(DFN,.312,IBCDFN,0)),"^",18)
I 'IBCPOL W !!,"Can't identify the plan!" S VALMBCK="" G ITQ
D ITEDIT(IBCPOL,IBCDFN)
ITQ ; Edit Insurance Type Exit
S VALMBCK="R"
Q
;
IT1 ; -- edit insurance type info from patient policy
D FULL^VALM1
;
;IB*2.0*549 - Added Security Key check
I '$D(^XUSEC("IB GROUP PLAN EDIT",DUZ)) D Q
. W !!,*7,"Sorry, but you do not have the required privileges to edit Insurance Type"
. W !,"Information."
. K DIR
. D PAUSE^VALM1
. S VALMBCK="R"
;
D ITEDIT(IBCPOL)
S VALMBCK="R"
Q
;
ITEDIT(IBCPOL,IBCDFN) ;Edit insurance type info once you have plan (IBCPOL)
; IBCDFN = the ifn of the policy multiple for pt in ^DPT, node .312
; only defined for editing via patient policy
G:'$G(IBCPOL) ITEDITQ
D SAVE^IBCNSP3(IBCPOL)
L +^IBA(355.3,+IBCPOL):5 I '$T D LOCKED^IBTRCD1 G ITEDITQ
I $G(IBCDFN) S IBCNSEH=+$G(^IBE(350.9,1,4)) D POL^IBCNSEH
I $P($G(^IBA(355.3,IBCPOL,0)),"^",11) W !?2,*7,"Please note that this plan is inactive!",!
S DA=IBCPOL,DIE="^IBA(355.3,",DR=".05;.12;.06;.07;.08"
D ^DIE K DIC,DIE,DA,DR
D COMP^IBCNSP3(IBCPOL)
I IBDIF D UPDATE^IBCNSP3(IBCPOL) D:$G(IBCDFN) UPDATPT^IBCNSP3(DFN,IBCDFN),BLD^IBCNSP D:'$G(IBCDFN) INIT^IBCNSC4
L -^IBA(355.3,+IBCPOL)
ITEDITQ Q
;
ED ; -- Edit effective dates
D FULL^VALM1 W !!
N IBDIF,DA,DR,DIE,DIC
D BEFORE^IBCNSEVT
D SAVEPT^IBCNSP3(DFN,IBCDFN)
L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G EDQ
D VARS^IBCNSP3
S DR="8;3;1.09//;3.04"
D ^DIE K DIC,DIE,DA,DR
D COMPPT^IBCNSP3(DFN,IBCDFN) I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),UPDCLM(DFN,IBCDFN),AFTER^IBCNSEVT,^IBCNSEVT,BLD^IBCNSP
L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4))
EDQ S VALMBCK="R" Q
;
VC ; -- Verify Coverage
D FULL^VALM1 W !!
D VFY^IBCNSM2
D BLD^IBCNSP
S VALMBCK="R" Q
;
SU ; -- Subscriber Update
D FULL^VALM1 W !!
;Patch 40
N IBDIF,DA,DR,DIC,DIE,DGSENFLG
S DGSENFLG=1
D SAVEPT^IBCNSP3(DFN,IBCDFN)
D VARS^IBCNSP3
L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G SUQ
;
D EDIT(DFN,IBCDFN) ; IB*371 - edit pat ins 2.312 subfile fields
;
D COMPPT^IBCNSP3(DFN,IBCDFN)
I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),BLD^IBCNSP
L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4))
SUQ S VALMBCK="R" Q
;
IC ; -- Insurance Contact Information
D FULL^VALM1 W !!
N IBDIF,DA,DR,DIC,DIE,IBTRC,DIR,DUOUT,DTOUT,DIRUT,IBTRN
D AI
D:$G(IBTRC) AIP^IBCNSP02(IBTRC),BLD^IBCNSP
S VALMBCK="R" Q
Q
AI ; -- Add ins. verification entry
N X,Y,I,J,DA,DR,DIC,DIE,DR,DD,DO,VA,VAIN,VAERR,IBQUIT,IBXIFN,IBTRN,DUOUT,IBX,IBQUIT,DTOUT
Q:'$G(DFN)
Q:'$G(IBCDFN) S IBQUIT=0
D AI^IBCNSP02
Q
;
PIDEF(IBREL,FLD,IBDFN,SPDEF) ; Function to return patient file defaults
; Called from input template IBCN PATIENT INSURANCE
; IBREL = value from 2.312,4.03 field (PT. RELATIONSHIP - HIPAA)
; FLD = field# in file 2.312
; IBDFN = patient ien to file 2
; SPDEF = spouse default flag =1 if this field should be defaulted
; when the spouse is the policy holder
;
; The purpose is to provide a default value for the field when the
; patient and the ins. subscriber are the same.
;
NEW VAL
S VAL=""
I +$G(IBREL)'=1,+$G(IBREL)'=18 G PIDEFX ; patient not the insured or spouse, get out
I +$G(IBREL)=1,'$G(SPDEF) G PIDEFX ; not a field for spouse default
I '$G(FLD) G PIDEFX ; no field# passed in
I '$G(IBDFN) G PIDEFX ; no patient passed in
;
; Build the patient demographics area
I '$D(^UTILITY("VADM",$J)) D
. N VAHOW,DFN,VADM
. S VAHOW=2,DFN=IBDFN D DEM^VADPT
. Q
;
; Build the patient address area
I '$D(^UTILITY("VAPA",$J)) D
. N VAHOW,DFN,VAPA
. S VAHOW=2,DFN=IBDFN,VAPA("P")="" D ADD^VADPT
. Q
;
I FLD=7.01 S VAL=$P($G(^UTILITY("VADM",$J,1)),U,1) G PIDEFX ; Name - IB*2.0*497 (vd)
I FLD=3.01 S VAL=$$FMTE^XLFDT($P($G(^UTILITY("VADM",$J,3)),U,1),"5Z") G PIDEFX ; Date of Birth
I FLD=3.02 S VAL=$$EXTERNAL^DILFD(2,.325,,$P($G(^DPT(IBDFN,.32)),U,5)) G PIDEFX ; Branch
I FLD=3.05 S VAL=$P($G(^UTILITY("VADM",$J,2)),U,2) G PIDEFX ; SSN
I FLD=3.06 S VAL=$P($G(^UTILITY("VAPA",$J,1)),U,1) G PIDEFX ; Street Address 1
I FLD=3.07 S VAL=$P($G(^UTILITY("VAPA",$J,2)),U,1) G PIDEFX ; Street Address 2
I FLD=3.08 S VAL=$P($G(^UTILITY("VAPA",$J,4)),U,1) G PIDEFX ; City
I FLD=3.09 S VAL=$P($G(^UTILITY("VAPA",$J,5)),U,2) G PIDEFX ; State
I FLD=3.1 S VAL=$P($G(^UTILITY("VAPA",$J,11)),U,2) G PIDEFX ; Zipcode
I FLD=3.11 S VAL=$P($G(^UTILITY("VAPA",$J,8)),U,1) G PIDEFX ; Phone#
I FLD=3.12 S VAL=$P($G(^UTILITY("VADM",$J,5)),U,2) G PIDEFX ; Sex
PIDEFX ;
Q VAL
;
ASK(QUES,DEFLT) ; Function to ask Yes/No Question
; Returns 1 (yes), 0 (no, up-arrow, or timeout)
NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="Y",DIR("A")=$G(QUES)
S DIR("B")=$S($G(DEFLT):"Yes",1:"No")
W ! D ^DIR W:Y !
I $D(DIRUT) S Y=0
ASKX ;
Q Y
;
EDIT(IBDFN,IBCDFN,IBQUIT) ; Main call to edit data in 2.312 pat ins subfile
; IBDFN - patient DFN
; IBCDFN - ien for patient insurance policy in subfile 2.312
; IBQUIT - Output variable. Pass by reference. Will be set to 1 if
; the user entered an up-arrow, timed-out, or deleted the
; 2.312 subfile entry by entering "@" at the .01 field
;
NEW DA,DR,DIE,IBZ,IBY,X,Y,DTOUT
NEW IDS,SUB,PAT,PCE,SUB1,PAT1
S DA(1)=+$G(IBDFN) ; patient IEN
S DA=+$G(IBCDFN) ; patient insurance IEN
I 'DA!'DA(1) G EDITX
S DIE="^DPT("_IBDFN_",.312,"
;
; Find the input template IEN for the [IBCN PATIENT INSURANCE] template
S IBY=+$$FIND1^DIC(.402,,"X","IBCN PATIENT INSURANCE")
I 'IBY G EDITX
;
; Build the DR array/string - ICR# 5002
M DR(1)=^DIE(IBY,"DR",2)
S DR=$G(DR(1,2.312))
I DR="" G EDITX
;
S $P(^DIE(IBY,0),U,7)=DT ; see TEM+2^DIE ICR# 5002
;
D ^DIE ; edit subfile data
;
; If the user entered an up-arrow, or timed-out, or deleted the entry,
; then set the output variable IBQUIT
I $D(Y)!$D(DTOUT)!'$D(DA) S IBQUIT=1
;
F IBZ="VADM","VAPA" K ^UTILITY(IBZ,$J) ; cleanup scratch global
;
D UPDCLM(IBDFN,IBCDFN) ; update editable claims
;
; Cleanup any problems in the secondary ID area
S IDS=$G(^DPT(IBDFN,.312,IBCDFN,5)) ; whole 5 node
S (SUB,PAT)=""
F PCE=3:1:8 S $P(SUB,U,PCE)=$P(IDS,U,PCE-1) ; subscriber sec ID/qual
F PCE=3:1:8 S $P(PAT,U,PCE)=$P(IDS,U,PCE+5) ; patient sec ID/qual
; SUB and PAT are 8-piece strings with pieces 1 and 2 being nil
S SUB1=$$SCRUB^IBCEF21(SUB) ; scrub 8-piece string
S PAT1=$$SCRUB^IBCEF21(PAT) ; scrub 8-piece string
I SUB'=SUB1 S $P(^DPT(IBDFN,.312,IBCDFN,5),U,2,7)=$P(SUB1,U,3,8)
I PAT'=PAT1 S $P(^DPT(IBDFN,.312,IBCDFN,5),U,8,13)=$P(PAT1,U,3,8)
;
EDITX ;
Q
;
UPDCLM(IBDFN,IBCDFN) ; Update the Insurance nodes of claims that are still editable
NEW IBIFN
S IBIFN=0 F S IBIFN=$O(^DGCR(399,"C",IBDFN,IBIFN)) Q:'IBIFN D UPDCLM^IBCNSP2(IBIFN,IBDFN,IBCDFN)
;
UPDCLMX ;
Q
;
PRELCNV(CODE,FLG) ; conversion between X12, NCPDP and VistA pt. relationship codes
; CODE - code for pt. relationship to convert
; FLG - 0 for X12 -> VistA conversion, 1 for VistA -> X12 conversion, 2 - for VistA -> NCPDP conversion
; returns converted code for pt. relationship, or null if no match found
N I,RES,VSTR,X12STR
S VSTR="01^02^03^08^11^15^32^33^34^35^36"
S X12STR="18^01^19^20^39^41^32^33^29^53^G8"
S RES=""
I FLG=0 F I=1:1:11 S:$P(X12STR,U,I)=CODE RES=$P(VSTR,U,I) Q:RES'=""
I FLG=1 F I=1:1:11 S:$P(VSTR,U,I)=CODE RES=$P(X12STR,U,I) Q:RES'=""
I FLG=2,+CODE>0 S RES=$S(+CODE>3:"04",1:CODE)
Q RES
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSP1 9984 printed Dec 13, 2024@02:17:52 Page 2
IBCNSP1 ;ALB/AAS - INSURANCE MANAGEMENT - policy actions ;05-MAY-2015
+1 ;;2.0;INTEGRATED BILLING;**6,28,40,43,52,85,103,361,371,377,497,549**;21-MAR-94;Build 54
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;ICR#5002 for read of ^DIE input template data
+4 ;
% GOTO EN^IBCNSP
+1 ;
EA ; -- Edit all
+1 NEW IBCDFN,IBTRC,IBTRN
+2 DO FULL^VALM1
+3 ;
+4 ;IB*2.0*549 - Added Security Key check
+5 IF '$DATA(^XUSEC("IB GROUP PLAN EDIT",DUZ))
Begin DoDot:1
+6 WRITE !!,*7,"Sorry, but you do not have the required privileges to Edit All"
+7 KILL DIR
+8 DO PAUSE^VALM1
+9 DO EAQ
End DoDot:1
QUIT
+10 ;
+11 WRITE !!
+12 SET IBCDFN=$PIECE($GET(IBPPOL),"^",4)
+13 IF 'IBCDFN
WRITE !!,"Can't identify the policy!"
GOTO EAQ
+14 SET IBCNSEH=1
DO PAT^IBCNSEH
+15 ;
+16 DO BEFORE^IBCNSEVT
+17 DO PATPOL^IBCNSM32(IBCDFN)
+18 DO AFTER^IBCNSEVT
DO ^IBCNSEVT
+19 ;
+20 ; -- edit policy data
+21 DO POL^IBCNSEH
+22 DO EDPOL^IBCNSM3(IBCDFN)
+23 ;
+24 WRITE !!
+25 DO AI
+26 ;
EAQ ; Edit All Exit
+1 if $GET(IBTRC)
DO AIP^IBCNSP02(IBTRC)
+2 DO BLD^IBCNSP
+3 SET VALMBCK="R"
+4 QUIT
+5 ;
AB ; -- Annual Benefits
+1 ;
+2 ; IB*2.0*549 - Added Security Key check
+3 IF '$DATA(^XUSEC("IB GROUP PLAN EDIT",DUZ))
Begin DoDot:1
+4 WRITE !!,*7,"Sorry, but you do not have the required privileges to edit Annual Benefits."
+5 KILL DIR
+6 DO PAUSE^VALM1
+7 SET VALMBCK="R"
End DoDot:1
QUIT
+8 ;
+9 SET X=+$PIECE($GET(IBPPOL),"^",4)
SET IBCNS=+$GET(^DPT(DFN,.312,X,0))
SET IBCPOL=+$PIECE($GET(^(0)),"^",18)
+10 IF 'IBCPOL
WRITE !!,"Can't identify the plan!"
SET VALMBCK=""
GOTO ABQ
+11 DO FULL^VALM1
WRITE !!
+12 DO EN^VALM("IBCNS ANNUAL BENEFITS")
+13 SET VALMBCK="R"
ABQ QUIT
+1 ;
BU ; -- Benefits Used
+1 SET IBCDFN=+$PIECE($GET(IBPPOL),"^",4)
SET IBCNS=+$GET(^DPT(DFN,.312,IBCDFN,0))
SET IBCPOL=+$PIECE($GET(^(0)),"^",18)
+2 IF 'IBCPOL
WRITE !!,"Can't identify the plan!"
SET VALMBCK=""
GOTO BUQ
+3 DO FULL^VALM1
WRITE !!
+4 DO EN^VALM("IBCNS BENEFITS USED BY DATE")
+5 SET VALMBCK="R"
BUQ QUIT
+1 ;
IT ; -- edit insurance type info from patient policy and plan edit
+1 DO FULL^VALM1
+2 ;
+3 ;IB*2.0*549 - Added Security Key check
+4 IF '$DATA(^XUSEC("IB GROUP PLAN EDIT",DUZ))
Begin DoDot:1
+5 WRITE !!,*7,"Sorry, but you do not have the required privileges to edit Insurance Type"
+6 WRITE !,"Information."
+7 KILL DIR
+8 DO PAUSE^VALM1
+9 DO ITQ
End DoDot:1
QUIT
+10 ;
+11 WRITE !!
+12 NEW IBCDFN
+13 SET IBCDFN=+$PIECE($GET(IBPPOL),"^",4)
SET IBCPOL=+$PIECE($GET(^DPT(DFN,.312,IBCDFN,0)),"^",18)
+14 IF 'IBCPOL
WRITE !!,"Can't identify the plan!"
SET VALMBCK=""
GOTO ITQ
+15 DO ITEDIT(IBCPOL,IBCDFN)
ITQ ; Edit Insurance Type Exit
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
IT1 ; -- edit insurance type info from patient policy
+1 DO FULL^VALM1
+2 ;
+3 ;IB*2.0*549 - Added Security Key check
+4 IF '$DATA(^XUSEC("IB GROUP PLAN EDIT",DUZ))
Begin DoDot:1
+5 WRITE !!,*7,"Sorry, but you do not have the required privileges to edit Insurance Type"
+6 WRITE !,"Information."
+7 KILL DIR
+8 DO PAUSE^VALM1
+9 SET VALMBCK="R"
End DoDot:1
QUIT
+10 ;
+11 DO ITEDIT(IBCPOL)
+12 SET VALMBCK="R"
+13 QUIT
+14 ;
ITEDIT(IBCPOL,IBCDFN) ;Edit insurance type info once you have plan (IBCPOL)
+1 ; IBCDFN = the ifn of the policy multiple for pt in ^DPT, node .312
+2 ; only defined for editing via patient policy
+3 if '$GET(IBCPOL)
GOTO ITEDITQ
+4 DO SAVE^IBCNSP3(IBCPOL)
+5 LOCK +^IBA(355.3,+IBCPOL):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO ITEDITQ
+6 IF $GET(IBCDFN)
SET IBCNSEH=+$GET(^IBE(350.9,1,4))
DO POL^IBCNSEH
+7 IF $PIECE($GET(^IBA(355.3,IBCPOL,0)),"^",11)
WRITE !?2,*7,"Please note that this plan is inactive!",!
+8 SET DA=IBCPOL
SET DIE="^IBA(355.3,"
SET DR=".05;.12;.06;.07;.08"
+9 DO ^DIE
KILL DIC,DIE,DA,DR
+10 DO COMP^IBCNSP3(IBCPOL)
+11 IF IBDIF
DO UPDATE^IBCNSP3(IBCPOL)
if $GET(IBCDFN)
DO UPDATPT^IBCNSP3(DFN,IBCDFN)
DO BLD^IBCNSP
if '$GET(IBCDFN)
DO INIT^IBCNSC4
+12 LOCK -^IBA(355.3,+IBCPOL)
ITEDITQ QUIT
+1 ;
ED ; -- Edit effective dates
+1 DO FULL^VALM1
WRITE !!
+2 NEW IBDIF,DA,DR,DIE,DIC
+3 DO BEFORE^IBCNSEVT
+4 DO SAVEPT^IBCNSP3(DFN,IBCDFN)
+5 LOCK +^DPT(DFN,.312,+$PIECE($GET(IBPPOL),"^",4)):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO EDQ
+6 DO VARS^IBCNSP3
+7 SET DR="8;3;1.09//;3.04"
+8 DO ^DIE
KILL DIC,DIE,DA,DR
+9 DO COMPPT^IBCNSP3(DFN,IBCDFN)
IF IBDIF
DO UPDATPT^IBCNSP3(DFN,IBCDFN)
DO UPDCLM(DFN,IBCDFN)
DO AFTER^IBCNSEVT
DO ^IBCNSEVT
DO BLD^IBCNSP
+10 LOCK -^DPT(DFN,.312,+$PIECE($GET(IBPPOL),"^",4))
EDQ SET VALMBCK="R"
QUIT
+1 ;
VC ; -- Verify Coverage
+1 DO FULL^VALM1
WRITE !!
+2 DO VFY^IBCNSM2
+3 DO BLD^IBCNSP
+4 SET VALMBCK="R"
QUIT
+5 ;
SU ; -- Subscriber Update
+1 DO FULL^VALM1
WRITE !!
+2 ;Patch 40
+3 NEW IBDIF,DA,DR,DIC,DIE,DGSENFLG
+4 SET DGSENFLG=1
+5 DO SAVEPT^IBCNSP3(DFN,IBCDFN)
+6 DO VARS^IBCNSP3
+7 LOCK +^DPT(DFN,.312,+$PIECE($GET(IBPPOL),"^",4)):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO SUQ
+8 ;
+9 ; IB*371 - edit pat ins 2.312 subfile fields
DO EDIT(DFN,IBCDFN)
+10 ;
+11 DO COMPPT^IBCNSP3(DFN,IBCDFN)
+12 IF IBDIF
DO UPDATPT^IBCNSP3(DFN,IBCDFN)
DO BLD^IBCNSP
+13 LOCK -^DPT(DFN,.312,+$PIECE($GET(IBPPOL),"^",4))
SUQ SET VALMBCK="R"
QUIT
+1 ;
IC ; -- Insurance Contact Information
+1 DO FULL^VALM1
WRITE !!
+2 NEW IBDIF,DA,DR,DIC,DIE,IBTRC,DIR,DUOUT,DTOUT,DIRUT,IBTRN
+3 DO AI
+4 if $GET(IBTRC)
DO AIP^IBCNSP02(IBTRC)
DO BLD^IBCNSP
+5 SET VALMBCK="R"
QUIT
+6 QUIT
AI ; -- Add ins. verification entry
+1 NEW X,Y,I,J,DA,DR,DIC,DIE,DR,DD,DO,VA,VAIN,VAERR,IBQUIT,IBXIFN,IBTRN,DUOUT,IBX,IBQUIT,DTOUT
+2 if '$GET(DFN)
QUIT
+3 if '$GET(IBCDFN)
QUIT
SET IBQUIT=0
+4 DO AI^IBCNSP02
+5 QUIT
+6 ;
PIDEF(IBREL,FLD,IBDFN,SPDEF) ; Function to return patient file defaults
+1 ; Called from input template IBCN PATIENT INSURANCE
+2 ; IBREL = value from 2.312,4.03 field (PT. RELATIONSHIP - HIPAA)
+3 ; FLD = field# in file 2.312
+4 ; IBDFN = patient ien to file 2
+5 ; SPDEF = spouse default flag =1 if this field should be defaulted
+6 ; when the spouse is the policy holder
+7 ;
+8 ; The purpose is to provide a default value for the field when the
+9 ; patient and the ins. subscriber are the same.
+10 ;
+11 NEW VAL
+12 SET VAL=""
+13 ; patient not the insured or spouse, get out
IF +$GET(IBREL)'=1
IF +$GET(IBREL)'=18
GOTO PIDEFX
+14 ; not a field for spouse default
IF +$GET(IBREL)=1
IF '$GET(SPDEF)
GOTO PIDEFX
+15 ; no field# passed in
IF '$GET(FLD)
GOTO PIDEFX
+16 ; no patient passed in
IF '$GET(IBDFN)
GOTO PIDEFX
+17 ;
+18 ; Build the patient demographics area
+19 IF '$DATA(^UTILITY("VADM",$JOB))
Begin DoDot:1
+20 NEW VAHOW,DFN,VADM
+21 SET VAHOW=2
SET DFN=IBDFN
DO DEM^VADPT
+22 QUIT
End DoDot:1
+23 ;
+24 ; Build the patient address area
+25 IF '$DATA(^UTILITY("VAPA",$JOB))
Begin DoDot:1
+26 NEW VAHOW,DFN,VAPA
+27 SET VAHOW=2
SET DFN=IBDFN
SET VAPA("P")=""
DO ADD^VADPT
+28 QUIT
End DoDot:1
+29 ;
+30 ; Name - IB*2.0*497 (vd)
IF FLD=7.01
SET VAL=$PIECE($GET(^UTILITY("VADM",$JOB,1)),U,1)
GOTO PIDEFX
+31 ; Date of Birth
IF FLD=3.01
SET VAL=$$FMTE^XLFDT($PIECE($GET(^UTILITY("VADM",$JOB,3)),U,1),"5Z")
GOTO PIDEFX
+32 ; Branch
IF FLD=3.02
SET VAL=$$EXTERNAL^DILFD(2,.325,,$PIECE($GET(^DPT(IBDFN,.32)),U,5))
GOTO PIDEFX
+33 ; SSN
IF FLD=3.05
SET VAL=$PIECE($GET(^UTILITY("VADM",$JOB,2)),U,2)
GOTO PIDEFX
+34 ; Street Address 1
IF FLD=3.06
SET VAL=$PIECE($GET(^UTILITY("VAPA",$JOB,1)),U,1)
GOTO PIDEFX
+35 ; Street Address 2
IF FLD=3.07
SET VAL=$PIECE($GET(^UTILITY("VAPA",$JOB,2)),U,1)
GOTO PIDEFX
+36 ; City
IF FLD=3.08
SET VAL=$PIECE($GET(^UTILITY("VAPA",$JOB,4)),U,1)
GOTO PIDEFX
+37 ; State
IF FLD=3.09
SET VAL=$PIECE($GET(^UTILITY("VAPA",$JOB,5)),U,2)
GOTO PIDEFX
+38 ; Zipcode
IF FLD=3.1
SET VAL=$PIECE($GET(^UTILITY("VAPA",$JOB,11)),U,2)
GOTO PIDEFX
+39 ; Phone#
IF FLD=3.11
SET VAL=$PIECE($GET(^UTILITY("VAPA",$JOB,8)),U,1)
GOTO PIDEFX
+40 ; Sex
IF FLD=3.12
SET VAL=$PIECE($GET(^UTILITY("VADM",$JOB,5)),U,2)
GOTO PIDEFX
PIDEFX ;
+1 QUIT VAL
+2 ;
ASK(QUES,DEFLT) ; Function to ask Yes/No Question
+1 ; Returns 1 (yes), 0 (no, up-arrow, or timeout)
+2 NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
+3 SET DIR(0)="Y"
SET DIR("A")=$GET(QUES)
+4 SET DIR("B")=$SELECT($GET(DEFLT):"Yes",1:"No")
+5 WRITE !
DO ^DIR
if Y
WRITE !
+6 IF $DATA(DIRUT)
SET Y=0
ASKX ;
+1 QUIT Y
+2 ;
EDIT(IBDFN,IBCDFN,IBQUIT) ; Main call to edit data in 2.312 pat ins subfile
+1 ; IBDFN - patient DFN
+2 ; IBCDFN - ien for patient insurance policy in subfile 2.312
+3 ; IBQUIT - Output variable. Pass by reference. Will be set to 1 if
+4 ; the user entered an up-arrow, timed-out, or deleted the
+5 ; 2.312 subfile entry by entering "@" at the .01 field
+6 ;
+7 NEW DA,DR,DIE,IBZ,IBY,X,Y,DTOUT
+8 NEW IDS,SUB,PAT,PCE,SUB1,PAT1
+9 ; patient IEN
SET DA(1)=+$GET(IBDFN)
+10 ; patient insurance IEN
SET DA=+$GET(IBCDFN)
+11 IF 'DA!'DA(1)
GOTO EDITX
+12 SET DIE="^DPT("_IBDFN_",.312,"
+13 ;
+14 ; Find the input template IEN for the [IBCN PATIENT INSURANCE] template
+15 SET IBY=+$$FIND1^DIC(.402,,"X","IBCN PATIENT INSURANCE")
+16 IF 'IBY
GOTO EDITX
+17 ;
+18 ; Build the DR array/string - ICR# 5002
+19 MERGE DR(1)=^DIE(IBY,"DR",2)
+20 SET DR=$GET(DR(1,2.312))
+21 IF DR=""
GOTO EDITX
+22 ;
+23 ; see TEM+2^DIE ICR# 5002
SET $PIECE(^DIE(IBY,0),U,7)=DT
+24 ;
+25 ; edit subfile data
DO ^DIE
+26 ;
+27 ; If the user entered an up-arrow, or timed-out, or deleted the entry,
+28 ; then set the output variable IBQUIT
+29 IF $DATA(Y)!$DATA(DTOUT)!'$DATA(DA)
SET IBQUIT=1
+30 ;
+31 ; cleanup scratch global
FOR IBZ="VADM","VAPA"
KILL ^UTILITY(IBZ,$JOB)
+32 ;
+33 ; update editable claims
DO UPDCLM(IBDFN,IBCDFN)
+34 ;
+35 ; Cleanup any problems in the secondary ID area
+36 ; whole 5 node
SET IDS=$GET(^DPT(IBDFN,.312,IBCDFN,5))
+37 SET (SUB,PAT)=""
+38 ; subscriber sec ID/qual
FOR PCE=3:1:8
SET $PIECE(SUB,U,PCE)=$PIECE(IDS,U,PCE-1)
+39 ; patient sec ID/qual
FOR PCE=3:1:8
SET $PIECE(PAT,U,PCE)=$PIECE(IDS,U,PCE+5)
+40 ; SUB and PAT are 8-piece strings with pieces 1 and 2 being nil
+41 ; scrub 8-piece string
SET SUB1=$$SCRUB^IBCEF21(SUB)
+42 ; scrub 8-piece string
SET PAT1=$$SCRUB^IBCEF21(PAT)
+43 IF SUB'=SUB1
SET $PIECE(^DPT(IBDFN,.312,IBCDFN,5),U,2,7)=$PIECE(SUB1,U,3,8)
+44 IF PAT'=PAT1
SET $PIECE(^DPT(IBDFN,.312,IBCDFN,5),U,8,13)=$PIECE(PAT1,U,3,8)
+45 ;
EDITX ;
+1 QUIT
+2 ;
UPDCLM(IBDFN,IBCDFN) ; Update the Insurance nodes of claims that are still editable
+1 NEW IBIFN
+2 SET IBIFN=0
FOR
SET IBIFN=$ORDER(^DGCR(399,"C",IBDFN,IBIFN))
if 'IBIFN
QUIT
DO UPDCLM^IBCNSP2(IBIFN,IBDFN,IBCDFN)
+3 ;
UPDCLMX ;
+1 QUIT
+2 ;
PRELCNV(CODE,FLG) ; conversion between X12, NCPDP and VistA pt. relationship codes
+1 ; CODE - code for pt. relationship to convert
+2 ; FLG - 0 for X12 -> VistA conversion, 1 for VistA -> X12 conversion, 2 - for VistA -> NCPDP conversion
+3 ; returns converted code for pt. relationship, or null if no match found
+4 NEW I,RES,VSTR,X12STR
+5 SET VSTR="01^02^03^08^11^15^32^33^34^35^36"
+6 SET X12STR="18^01^19^20^39^41^32^33^29^53^G8"
+7 SET RES=""
+8 IF FLG=0
FOR I=1:1:11
if $PIECE(X12STR,U,I)=CODE
SET RES=$PIECE(VSTR,U,I)
if RES'=""
QUIT
+9 IF FLG=1
FOR I=1:1:11
if $PIECE(VSTR,U,I)=CODE
SET RES=$PIECE(X12STR,U,I)
if RES'=""
QUIT
+10 IF FLG=2
IF +CODE>0
SET RES=$SELECT(+CODE>3:"04",1:CODE)
+11 QUIT RES
