- 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 Jan 18, 2025@03:19:04 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