- IBCNBAA ;ALB/ARH/AWC - Ins Buffer: process Accept set-up ;1 Jun 97
- ;;2.0;INTEGRATED BILLING;**82,184,246,416,506,528,668,737**;21-MAR-94;Build 19
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;
- ;/vd-IB*2*668 - Removed the SSVI logic introduced with IB*2*528 in its entirety within VistA.
- ACCEPT(IBBUFDA,IBINSDA,IBGRPDA,IBPOLDA) ; process a buffer entry for acceptance then save in Insurance files
- ; 1) for Insurance Company, Group/Plan and Policy sets of data:
- ; a) display the set of buffer data and corresponding existing selected ins data
- ; b) if ins record exists confirm with user that it is the correct one to use
- ; c) if ins record exists user selects method of saving to ins record: Merge/Overwrite/Replace/No Change/Individually Accept(skip blanks)
- ; d) if new record needs to be created get user confirmation
- ; 2) display the actions that will be taken
- ; 3) user confirms that is correct
- ; 4) data moved into insurance files, new records created if needed or edit existing ones
- ; 5) complete some general functions that are executed whenever insurance is entered/edited
- ; 6) allow user to view buffer entry and new/updated insurance records
- ; 7) buffer ins/group/policy data deleted
- ; 8) buffer entry status updated
- ;
- N DFN,IBX,IBELIG,IBHELP,IBNEWINS,IBNEWGRP,IBNEWPOL,IBNEWSUB,IBMVINS,IBMVGRP,IBMVPOL,IBMVSUB,IBACCPT,IBVAL
- N DIR,X,Y,DIRUT,IBDONE,IBQ,IBYR,IBDA,IBEAB,IBXREF,IBO,IBISEL,IBERR,IBOUT,IBASAV,IBCSAV,IBIEN,IBRIEN,IBSIEN,IBFNAM,IBHOLD,IBXHOLD,IBSEL,IBSOURCE,IBIIU
- N DIERR
- S (IBDONE,IBIEN)=0
- K ^TMP($J,"IB BUFFER SELECTED") ; initialize selection file
- S IBINSDA=+$G(IBINSDA),IBGRPDA=+$G(IBGRPDA),IBPOLDA=+$G(IBPOLDA),(IBNEWINS,IBNEWGRP,IBNEWPOL,IBNEWSUB,IBMVINS,IBMVGRP,IBMVPOL,IBMVSUB,IBOUT,IBASAV,IBCSAV)=0
- S DFN=+$G(^IBA(355.33,+$G(IBBUFDA),60)) I 'DFN G ACCPTQ
- I +IBINSDA,+IBGRPDA,'IBPOLDA S IBPOLDA=$$PTGRP^IBCNBU1(DFN,IBINSDA,IBGRPDA) ; patient already member of plan
- ;
- I $P($G(^IBA(355.33,$G(IBBUFDA),0)),U,4)'="E" G ACCPTQ
- I +IBINSDA,$G(^DIC(36,IBINSDA,0))="" G ACCPTQ
- I +IBGRPDA,+$G(^IBA(355.3,IBGRPDA,0))'=IBINSDA G ACCPTQ
- I +IBGRPDA S IBX=$G(^IBA(355.3,IBGRPDA,0)) I $P(IBX,U,2)=0,+$P(IBX,U,10),$P(IBX,U,10)'=DFN G ACCPTQ
- I +IBPOLDA,+$G(^DPT(DFN,.312,IBPOLDA,0))'=IBINSDA G ACCPTQ
- I +IBPOLDA,$P($G(^DPT(DFN,.312,IBPOLDA,0)),U,18)'=IBGRPDA G ACCPTQ
- ;
- ACINS ;
- W @IOF S IBHELP=",INS^IBCNBCD("_IBBUFDA_","_IBINSDA_")"
- D INS^IBCNBCD(IBBUFDA,IBINSDA)
- I +IBINSDA S IBACCPT=$$MATCH("INSURANCE COMPANY") S:'IBACCPT (IBINSDA,IBGRPDA,IBPOLDA)=0 I $D(DIRUT) G ACCPTQ
- I +IBINSDA D I $D(DIRUT)!(IBMVINS="") G ACCPTQ
- . I '$D(^XUSEC("IB INSURANCE COMPANY EDIT",DUZ)) S IBMVINS=0 Q
- . S IBMVINS=$$MOVE("INSURANCE COMPANY",IBHELP)
- I 'IBINSDA S IBNEWINS=$$NEW("INSURANCE COMPANY"),IBMVINS=3,(IBGRPDA,IBPOLDA)=0 I 'IBNEWINS G ACCPTQ
- ;
- I +IBMVINS=4 D INS^IBCNBAC(IBBUFDA,IBINSDA,1) ; Ind. Accept-Skip Blanks
- ;
- ACGRP ;
- W @IOF S IBHELP=",GRP^IBCNBCD("_IBBUFDA_","_IBGRPDA_")"
- I +IBGRPDA W !,?14,"Patient is "_$S(+IBPOLDA:"",1:"NOT ")_"a member of this Insurance Group/Plan",!
- D GRP^IBCNBCD(IBBUFDA,IBGRPDA)
- ;
- I +IBGRPDA S IBACCPT=$$MATCH("GROUP/PLAN") S:'IBACCPT (IBGRPDA,IBPOLDA)=0 I $D(DIRUT) G ACCPTQ
- I +IBGRPDA D I $D(DIRUT)!(IBMVGRP="") G ACCPTQ
- . I '$D(^XUSEC("IB GROUP PLAN EDIT",DUZ)) S IBMVGRP=0 Q
- . S IBMVGRP=$$MOVE("GROUP/PLAN",IBHELP)
- I 'IBGRPDA S IBNEWGRP=$$NEW("GROUP/PLAN"),IBMVGRP=3,IBPOLDA=0 I 'IBNEWGRP G ACCPTQ
- ;
- I +IBMVGRP=4 D GRP^IBCNBAC(IBBUFDA,IBGRPDA,1) ; Ind. Accept-Skip Blanks
- ;
- ACANB ; -- Annual Benefits /awc
- I +IBGRPDA D ANNBEN^IBCNBCD1(IBBUFDA,IBGRPDA,.IBASAV,.IBQ,.IBERR) I IBQ=U!($D(IBERR))!($D(DTOUT)) G ACCPTQ
- ;
- ACCOV ; -- Coverage Limitations /awc
- I +IBGRPDA D COVLIM^IBCNBCD2(IBBUFDA,IBGRPDA,.IBCSAV,.IBQ,.IBERR) I IBQ=U!($D(IBERR))!($D(DTOUT)) G ACCPTQ
- ;
- ACPOL ;
- W @IOF S IBHELP=",POLICY^IBCNBCD("_IBBUFDA_","_IBPOLDA_")"
- I 'IBPOLDA W !,"This will be a New policy for this group and patient.",!
- D POLICY^IBCNBCD(IBBUFDA,IBPOLDA)
- I +IBPOLDA S IBACCPT=$$MATCH("PATIENT POLICY") S:'IBACCPT IBPOLDA=0 I $D(DIRUT) G ACCPTQ
- I +IBPOLDA S IBMVPOL=$$MOVE("PATIENT POLICY",IBHELP) I $D(DIRUT)!(IBMVPOL="") G ACCPTQ
- I 'IBPOLDA S IBNEWPOL=$$NEW("PATIENT POLICY"),IBMVPOL=3 I 'IBNEWPOL G ACCPTQ
- ;
- I +IBMVPOL=4 D POLICY^IBCNBAC(IBBUFDA,IBPOLDA,1) ; Ind. Accept-Skip Blanks
- ;
- ACSUB ; -- Subscriber screens
- W @IOF
- S IBMVSUB="0^NO CHANGE",(IBFNAM,IBVAL,IBHOLD,IBXHOLD)="",IBRIEN=0
- S IBSIEN=$S(+IBPOLDA:IBPOLDA_","_DFN_",",1:0)
- ;
- S IBSEL=+$$SUASK(.IBVAL) I $D(DUOUT)!($D(DTOUT)) G ACCPTQ
- ;
- I IBSEL'=1&(IBSEL'=18) W !,!,"*** Warning - Please Complete Subscriber Update Fields Manually via the Patient Insurance File." D WAIT G ACEB
- E D I IBOUT!($D(DTOUT)) G ACCPTQ
- . ;
- . I 'IBPOLDA S IBMVSUB=3 W !,"A NEW Subscriber Insurance policy must be created for this group/patient before Subscriber updates.",! D WAIT Q
- . ;
- . ; -- display subscriber screens
- . D SBDISP^IBCNBCD4(IBBUFDA,DFN,IBPOLDA,IBSEL,IBRIEN,IBSIEN,.IBFNAM,IBVAL,.IBHOLD,.IBXHOLD) I $D(DIERR) S IBOUT=1 Q
- . ;
- . ; -- display M/O/R/N/I screens
- . I +IBPOLDA S IBACCPT=$$SBMATCH("SUBSCRIBER INSURANCE") S:'IBACCPT IBPOLDA=0 I $D(DIRUT) S IBOUT=1 Q
- . I +IBPOLDA S IBMVSUB=$$SBMOVE("SUBSCRIBER INSURANCE") I $D(DIRUT)!(IBMVSUB="") S IBOUT=1 Q
- . ;
- . I +IBMVSUB=4 D SUB^IBCNBAC(1,IBFNAM,.IBHOLD,.IBXHOLD) ; Ind. Accept-Skip Blanks
- ;
- ACEB ;
- W @IOF
- D ELIG^IBCNBCD(IBBUFDA,IBPOLDA) S IBELIG=$$REPL() I $D(DIRUT) G ACCPTQ
- ;
- CHECK ; display changes that will be made and ask user for confirmation
- W @IOF
- ;
- I +IBINSDA S IBX="The Buffer data will "_$P(IBMVINS,U,2)_" the existing Insurance Company data."
- I +IBINSDA,'IBMVINS S IBX="There will be "_$P(IBMVINS,U,2)_" to the existing Insurance Company data."
- I 'IBINSDA S IBX=$P(^IBA(355.33,IBBUFDA,20),U,1)_" will be added as a NEW Insurance Company."
- W !!,$G(IORVON)_"STEP 1: Insurance Company"_$J("",55)_$G(IORVOFF) W !,IBX
- ;
- I +IBGRPDA S IBX="The Buffer data will "_$P(IBMVGRP,U,2)_" the existing Group/Plan data."
- I +IBGRPDA,'IBMVGRP S IBX="There will be "_$P(IBMVGRP,U,2)_" to the existing Group/Plan data."
- I 'IBGRPDA S IBX="A NEW Group Plan will be added to this Insurance Company."
- W !!,$G(IORVON)_"STEP 2: Group/Plan"_$J("",62)_$G(IORVOFF) W !,IBX
- ;
- ; AWC/ Annual Benefits
- I 'IBPOLDA S IBX="There is no Patient Insurance Policy for this patient and this Group/Plan."
- E I +IBPOLDA D
- . I IBASAV S IBX="Edited Data was SAVED into the Annual Benefits File." Q
- . S IBX="No Edits made/saved. No data saved into the Annual Benefits File."
- W !!,$G(IORVON)_"STEP 3: Annual Benefits"_$J("",57)_$G(IORVOFF) W !,IBX
- ;
- ; AWC/ Coverage Limitations
- I 'IBPOLDA S IBX="There is no Patient Insurance Policy for this patient and this Group/Plan."
- E I +IBPOLDA D
- . I IBCSAV S IBX="Edited data was SAVED into the Coverage Limitations File." Q
- . S IBX="No Edits made/saved. No data saved into the Coverage Limitations File."
- W !!,$G(IORVON)_"STEP 4: Coverage Limitation"_$J("",53)_$G(IORVOFF) W !,IBX
- ;
- ; AWC/ Moved Patient Policy to Step 5
- I +IBPOLDA S IBX="The Buffer data will "_$P(IBMVPOL,U,2)_" the existing Policy data."
- I +IBPOLDA,'IBMVPOL S IBX="There will be "_$P(IBMVPOL,U,2)_" to the existing Policy data."
- I 'IBPOLDA S IBX="A NEW Patient Policy will be added for this patient and this Group/Plan."
- W !!,$G(IORVON)_"STEP 5: Patient Policy"_$J("",58)_$G(IORVOFF) W !,IBX
- ;
- ; AWC/ Subscriber
- I +IBPOLDA S IBX="The Patient Registration data will "_$P(IBMVSUB,U,2)_" the existing Patient Insurance data."
- I +IBPOLDA,'IBMVSUB S IBX="There will be "_$P(IBMVSUB,U,2)_" to the existing Patient Insurance data."
- I 'IBPOLDA S IBX="A NEW Patient Insurance Policy will be added for this patient and this Group/Plan."
- W !!,$G(IORVON)_"STEP 6: Subscriber Update"_$J("",55)_$G(IORVOFF) W !,IBX
- I IBSEL'=1&(IBSEL'=18) S IBX="Please Complete Subscriber Update Fields Manually via the Patient Insurance File." W !,IBX
- ;
- ; AWC/ Moved Eligibility/Benefits to Step 7
- S IBX="The Buffer data will"_$S(IBELIG:"",1:" not")_" replace the existing EB data."
- W !!,$G(IORVON)_"STEP 7: Eligibility/Benefits"_$J("",52)_$G(IORVOFF) W !,IBX
- ;
- I +IBINSDA,$P(IBMVINS,U,1)=0,+IBGRPDA,$P(IBMVGRP,U,1)=0,+IBPOLDA,$P(IBMVPOL,U,1)=0,$P(IBMVSUB,U,1)=0,+IBELIG=0 W !!!,"This would result in No Change to the existing Insurance data. Process aborted." D WAIT G ACCPTQ
- ;
- I '$$OK G ACCPTQ
- ;
- PROCESS ; process all changes selected by user, add/edit insurance files based on buffer data, cleanup, ...
- ;
- ;IB*737/CKB - IBBUFABORT is Newed in ACCEPT^IBCNBLA1
- D ACCEPT^IBCNBAR(IBBUFDA,DFN,IBINSDA,IBGRPDA,.IBPOLDA,IBMVINS,IBMVGRP,IBMVPOL,IBMVSUB,IBNEWINS,IBNEWGRP,IBNEWPOL,IBELIG,IBSEL,IBRIEN,.IBSIEN,IBFNAM,IBVAL,.IBHOLD,.IBXHOLD)
- I 'IBBUFABORT S IBDONE=1 ;IB*737/CKB
- ;
- ACCPTQ ;
- Q IBDONE
- ;
- LKPYR(IBGRPDA,ABYR) ; Look up year
- N X,Y,DA,DR,DIC
- S DA=IBGRPDA,DIC="^IBA(355.4,",DIC(0)="MZ",X=$P(ABYR,U,2)
- D ^DIC
- Q +Y
- ;
- MATCH(IBDESC) ; ask the user if the buffer entry is a match with the selected insurance file entry
- ; returns 1 if there is a match, 0 otherwise
- N DIR,X,Y,IBX S IBX=0
- S DIR("?")="Enter Yes if this existing "_IBDESC_" corresponds to the buffer entry "_IBDESC_". Enter No to add new "_IBDESC_"."
- S DIR("?",1)="Entering Yes will match this existing "_IBDESC_" with the buffer entry,"
- S DIR("?",2)="no new "_IBDESC_" will be created. Any existing "_IBDESC_" data"
- S DIR("?",3)="changes based on the Buffer data will be applied to this "_IBDESC_"."
- S DIR("?",4)="Enter No to create a new "_IBDESC_" if the Buffer entry's "
- S DIR("?",5)=IBDESC_" data does not match any existing "_IBDESC_".",DIR("?",6)=""
- ;
- W ! S DIR(0)="YO",DIR("A")="Is this the correct "_IBDESC_" to match with this Buffer entry" D ^DIR I Y=1 S IBX=1
- Q IBX
- ;
- SBMATCH(IBDESC) ; ask the user if the Patient Registration entry is a match with the selected insurance file entry
- ; returns 1 if there is a match, 0 otherwise
- N DIR,X,Y,IBX S IBX=0
- S DIR("?")="Enter Yes if this existing "_IBDESC_" corresponds to the Patient Registration entry. Enter No if not."
- S DIR("?",1)="Entering Yes will match this existing "_IBDESC_" with the Patient Registration entry,"
- S DIR("?",2)="no new "_IBDESC_" will be created. Any existing "_IBDESC_" data"
- S DIR("?",3)="changes based on the Patient Registration data will be applied to this "_IBDESC_"."
- S DIR("?",4)="Enter No to create a new "_IBDESC_" policy if the Patient Registration entry's "
- S DIR("?",5)=IBDESC_" data does not match any existing "_IBDESC_".",DIR("?",6)=""
- ;
- W ! S DIR(0)="YO",DIR("A")="Is this the correct "_IBDESC_" to match with this Patient Registration entry" D ^DIR I Y=1 S IBX=1
- Q IBX
- ;
- MOVE(IBDESC,IBHELP) ; ask the user what method they want to use to transfer buffer data to the insurance files
- ; returns 1^merge, 2^overwrite, 3^replace, 4^individually accept (skip blanks),
- ; 0^no change,
- ; or "" if none of the methods was chosen
- N DIR,X,Y,IBX S IBX=""
- S DIR("?")="^D HELP^IBCNBUH,WAIT^IBCNBAA"_$G(IBHELP),DIR("??")="^D HELP2^IBCNBUH,WAIT^IBCNBAA"_$G(IBHELP)
- S DIR("A")="Select the method to update the "_IBDESC
- ; DAOU/BHS - 08/28/2002 - Added INDIVIDUALLY ACCEPT methods
- W ! S DIR(0)="SOB^M:MERGE;O:OVERWRITE;R:REPLACE;N:NO CHANGE;I:INDIVIDUALLY ACCEPT (SKIP BLANKS)" D ^DIR
- S IBX=$S(Y="M":1,Y="O":2,Y="R":3,Y="I":4,Y="N":0,1:"") I IBX'="" S IBX=IBX_U_$G(Y(0))_$S(+IBX=1:" with",1:"")
- Q IBX
- ;
- SBMOVE(IBDESC) ; ask the user what method they want to use to transfer buffer data to the insurance files
- ; returns 1^merge, 2^overwrite, 3^replace, 4^individually accept (skip blanks),
- ; 0^no change,
- ; or "" if none of the methods was chosen
- N DIR,X,Y,IBX S IBX=""
- S DIR("?")="^D HELP^IBCNBUH,WAIT^IBCNBAA"_","_"SBDISP^IBCNBCD4(IBBUFDA,DFN,IBPOLDA,IBSEL,IBRIEN,IBSIEN,.IBFNAM,IBVAL,.IBHOLD,.IBXHOLD)"
- S DIR("??")="^D HELP2^IBCNBUH,WAIT^IBCNBAA"_","_"SBDISP^IBCNBCD4(IBBUFDA,DFN,IBPOLDA,IBSEL,IBRIEN,IBSIEN,.IBFNAM,IBVAL,.IBHOLD,.IBXHOLD)"
- S DIR("A")="Select the method to update the "_IBDESC
- ; DAOU/BHS - 08/28/2002 - Added INDIVIDUALLY ACCEPT methods
- W ! S DIR(0)="SOB^M:MERGE;O:OVERWRITE;R:REPLACE;N:NO CHANGE;I:INDIVIDUALLY ACCEPT (SKIP BLANKS)" D ^DIR
- S IBX=$S(Y="M":1,Y="O":2,Y="R":3,Y="I":4,Y="N":0,1:"") I IBX'="" S IBX=IBX_U_$G(Y(0))_$S(+IBX=1:" with",1:"")
- Q IBX
- ;
- NEW(IBDESC) ; ask user if they want to add a new entry to the insurance files (36, 355.3, or 2.312)
- ; returns 1 if Yes create a new entry, 0 otherwise
- N DIR,X,Y,IBX S IBX=0
- ;
- ; The following was changed with patch IB*2.0*506
- S DIR("?")="Enter Yes to create a new "_IBDESC_". Enter No to stop this process."
- S DIR("?",1)="Enter Yes to create a new "_IBDESC_" in the Insurance files for"
- S DIR("?",2)="this Buffer entry only if no existing "_IBDESC_" could be found"
- S DIR("?",3)="that matches this buffer entry.",DIR("?",4)=""
- W ! S DIR(0)="YO",DIR("A")="NO "_IBDESC_" Selected, do you need a New "_IBDESC D ^DIR I +Y=1 S IBX=1
- ;
- ;I IBDESC="INSURANCE COMPANY",'$D(^XUSEC("IB INSURANCE COMPANY ADD",DUZ)) W !!,"Sorry, but you do not have the required privileges to add",!,"new Insurance Companies." D WAIT G NEWQ
- I IBX=1 D G NEWQ
- . I IBDESC="INSURANCE COMPANY" D Q
- . . I '$D(^XUSEC("IB INSURANCE COMPANY EDIT",DUZ)) W !!,"A Supervisor will need to add the "_IBDESC_" before processing can",!,"continue." S IBX=0 D WAIT Q
- . . W !!,"You must create an "_IBDESC_" first." S IBX=0 D WAIT
- . I IBDESC="GROUP/PLAN" D Q
- . . I '$D(^XUSEC("IB GROUP PLAN EDIT",DUZ)) W !!,"A Supervisor will need to add the "_IBDESC_" before processing can continue." S IBX=0 D WAIT Q
- . . W !!,"You must create a "_IBDESC_" first." S IBX=0 D WAIT
- ;/IB*2.0*506 End
- NEWQ Q IBX
- ;
- REPL() ; ask user if they want to replace eligibility/benefits data in pt. insuarance
- N DIR,X,Y,IBX
- S IBX=0
- S DIR(0)="YO",DIR("A")="Replace the Pt's Eligibility/Benefits data",DIR("B")="YES"
- S DIR("?")="Enter Yes to replace existing Eligibility/Benefits data with one from eIV response."
- W ! D ^DIR I +Y=1 S IBX=1
- Q IBX
- ;
- OK() ; ask the user if the buffer data should be moved to the insurance files
- ; returns 1 if yes, 0 otherwise
- N DIR,X,Y,IBX S IBX=0 W !!!
- S DIR("?")="Enter Yes to accept/verify the buffer data and move it to the insurance files. Enter No to stop this process."
- S DIR("?",1)="Entering Yes will cause several things to happen:"
- S DIR("?",2)=" 1 - the above changes will be completed and the Insurance files updated with"
- S DIR("?",3)=" the buffer data."
- S DIR("?",4)=" 2 - the Insurance entries modified or added will be flagged as verified."
- S DIR("?",5)=" 3 - most of the insurance and patient related information in the buffer entry"
- S DIR("?",6)=" will be deleted, leaving only a stub entry for reporting purposes.",DIR("?",7)=""
- S DIR(0)="YO",DIR("A")="Is this Correct, update the existing Insurance files now" D ^DIR I Y=1 S IBX=1
- Q IBX
- ;
- WAIT N DIR,DIRUT,DUOUT,DTOUT,X,Y W !! S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR W !!
- Q
- ;
- SUASK(IBVAL) ; ask user to select Pt. Relationship to Insured
- N X,Y,DIR,IBF
- W !
- S IBF=$P($G(^DD(2.312,4.03,0)),U,3)
- ;
- S DIR(0)="SAO^"_IBF
- S DIR("A")="Select the Patient Relationship to Subscriber: "
- S DIR("?",1)=" Enter the code which best describes this patient's relationship"
- S DIR("?")=" to the person who holds this insurance policy (or insured)."
- D ^DIR I +Y S IBVAL=Y_U_$P($P(IBF,Y_":",2),";")
- Q +Y
- ;
- READ(IBRTYP,IBPROM,IBDFLT,IBHELP,IBSCRN) ; Reader that will returns a response to user input
- ; Input:
- ; IBRTYP : Read Type and Input modifiers^Input Parameters^Input Transform (Required)
- ; IBPROM : Prompt text that user will see
- ; IBDFLT : Default response
- ; IBHELP : Help text to display
- ; IBSCRN : Screen for pointer, set-of-code, and list/range reads
- ;
- N DIR,X,Y
- ;
- W !
- ;
- S DIR(0)=IBRTYP
- S:$G(IBPROM)]"" DIR("A")=IBPROM
- S:$G(IBDFLT)]"" DIR("B")=IBDFLT
- S:$G(IBHELP)]"" DIR("?")=IBHELP
- S:$G(IBSCRN)]"" DIR("S")=IBSCRN
- D ^DIR
- ;
- ; -- Return Y value concatonated with the .01 value of the zero node if look-up was successful
- ; -- <or> "@" if user deleted entry
- ; -- <or> -1, <or> "" if look-up not successful
- Q $S((Y'=-1&(Y]"")&($E(Y)'=U))&($L($G(Y),U)'=2):Y_U_$G(Y(0),Y),$G(X)="@":"@",1:Y)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNBAA 16473 printed Feb 18, 2025@23:40:09 Page 2
- IBCNBAA ;ALB/ARH/AWC - Ins Buffer: process Accept set-up ;1 Jun 97
- +1 ;;2.0;INTEGRATED BILLING;**82,184,246,416,506,528,668,737**;21-MAR-94;Build 19
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;
- +5 ;/vd-IB*2*668 - Removed the SSVI logic introduced with IB*2*528 in its entirety within VistA.
- ACCEPT(IBBUFDA,IBINSDA,IBGRPDA,IBPOLDA) ; process a buffer entry for acceptance then save in Insurance files
- +1 ; 1) for Insurance Company, Group/Plan and Policy sets of data:
- +2 ; a) display the set of buffer data and corresponding existing selected ins data
- +3 ; b) if ins record exists confirm with user that it is the correct one to use
- +4 ; c) if ins record exists user selects method of saving to ins record: Merge/Overwrite/Replace/No Change/Individually Accept(skip blanks)
- +5 ; d) if new record needs to be created get user confirmation
- +6 ; 2) display the actions that will be taken
- +7 ; 3) user confirms that is correct
- +8 ; 4) data moved into insurance files, new records created if needed or edit existing ones
- +9 ; 5) complete some general functions that are executed whenever insurance is entered/edited
- +10 ; 6) allow user to view buffer entry and new/updated insurance records
- +11 ; 7) buffer ins/group/policy data deleted
- +12 ; 8) buffer entry status updated
- +13 ;
- +14 NEW DFN,IBX,IBELIG,IBHELP,IBNEWINS,IBNEWGRP,IBNEWPOL,IBNEWSUB,IBMVINS,IBMVGRP,IBMVPOL,IBMVSUB,IBACCPT,IBVAL
- +15 NEW DIR,X,Y,DIRUT,IBDONE,IBQ,IBYR,IBDA,IBEAB,IBXREF,IBO,IBISEL,IBERR,IBOUT,IBASAV,IBCSAV,IBIEN,IBRIEN,IBSIEN,IBFNAM,IBHOLD,IBXHOLD,IBSEL,IBSOURCE,IBIIU
- +16 NEW DIERR
- +17 SET (IBDONE,IBIEN)=0
- +18 ; initialize selection file
- KILL ^TMP($JOB,"IB BUFFER SELECTED")
- +19 SET IBINSDA=+$GET(IBINSDA)
- SET IBGRPDA=+$GET(IBGRPDA)
- SET IBPOLDA=+$GET(IBPOLDA)
- SET (IBNEWINS,IBNEWGRP,IBNEWPOL,IBNEWSUB,IBMVINS,IBMVGRP,IBMVPOL,IBMVSUB,IBOUT,IBASAV,IBCSAV)=0
- +20 SET DFN=+$GET(^IBA(355.33,+$GET(IBBUFDA),60))
- IF 'DFN
- GOTO ACCPTQ
- +21 ; patient already member of plan
- IF +IBINSDA
- IF +IBGRPDA
- IF 'IBPOLDA
- SET IBPOLDA=$$PTGRP^IBCNBU1(DFN,IBINSDA,IBGRPDA)
- +22 ;
- +23 IF $PIECE($GET(^IBA(355.33,$GET(IBBUFDA),0)),U,4)'="E"
- GOTO ACCPTQ
- +24 IF +IBINSDA
- IF $GET(^DIC(36,IBINSDA,0))=""
- GOTO ACCPTQ
- +25 IF +IBGRPDA
- IF +$GET(^IBA(355.3,IBGRPDA,0))'=IBINSDA
- GOTO ACCPTQ
- +26 IF +IBGRPDA
- SET IBX=$GET(^IBA(355.3,IBGRPDA,0))
- IF $PIECE(IBX,U,2)=0
- IF +$PIECE(IBX,U,10)
- IF $PIECE(IBX,U,10)'=DFN
- GOTO ACCPTQ
- +27 IF +IBPOLDA
- IF +$GET(^DPT(DFN,.312,IBPOLDA,0))'=IBINSDA
- GOTO ACCPTQ
- +28 IF +IBPOLDA
- IF $PIECE($GET(^DPT(DFN,.312,IBPOLDA,0)),U,18)'=IBGRPDA
- GOTO ACCPTQ
- +29 ;
- ACINS ;
- +1 WRITE @IOF
- SET IBHELP=",INS^IBCNBCD("_IBBUFDA_","_IBINSDA_")"
- +2 DO INS^IBCNBCD(IBBUFDA,IBINSDA)
- +3 IF +IBINSDA
- SET IBACCPT=$$MATCH("INSURANCE COMPANY")
- if 'IBACCPT
- SET (IBINSDA,IBGRPDA,IBPOLDA)=0
- IF $DATA(DIRUT)
- GOTO ACCPTQ
- +4 IF +IBINSDA
- Begin DoDot:1
- +5 IF '$DATA(^XUSEC("IB INSURANCE COMPANY EDIT",DUZ))
- SET IBMVINS=0
- QUIT
- +6 SET IBMVINS=$$MOVE("INSURANCE COMPANY",IBHELP)
- End DoDot:1
- IF $DATA(DIRUT)!(IBMVINS="")
- GOTO ACCPTQ
- +7 IF 'IBINSDA
- SET IBNEWINS=$$NEW("INSURANCE COMPANY")
- SET IBMVINS=3
- SET (IBGRPDA,IBPOLDA)=0
- IF 'IBNEWINS
- GOTO ACCPTQ
- +8 ;
- +9 ; Ind. Accept-Skip Blanks
- IF +IBMVINS=4
- DO INS^IBCNBAC(IBBUFDA,IBINSDA,1)
- +10 ;
- ACGRP ;
- +1 WRITE @IOF
- SET IBHELP=",GRP^IBCNBCD("_IBBUFDA_","_IBGRPDA_")"
- +2 IF +IBGRPDA
- WRITE !,?14,"Patient is "_$SELECT(+IBPOLDA:"",1:"NOT ")_"a member of this Insurance Group/Plan",!
- +3 DO GRP^IBCNBCD(IBBUFDA,IBGRPDA)
- +4 ;
- +5 IF +IBGRPDA
- SET IBACCPT=$$MATCH("GROUP/PLAN")
- if 'IBACCPT
- SET (IBGRPDA,IBPOLDA)=0
- IF $DATA(DIRUT)
- GOTO ACCPTQ
- +6 IF +IBGRPDA
- Begin DoDot:1
- +7 IF '$DATA(^XUSEC("IB GROUP PLAN EDIT",DUZ))
- SET IBMVGRP=0
- QUIT
- +8 SET IBMVGRP=$$MOVE("GROUP/PLAN",IBHELP)
- End DoDot:1
- IF $DATA(DIRUT)!(IBMVGRP="")
- GOTO ACCPTQ
- +9 IF 'IBGRPDA
- SET IBNEWGRP=$$NEW("GROUP/PLAN")
- SET IBMVGRP=3
- SET IBPOLDA=0
- IF 'IBNEWGRP
- GOTO ACCPTQ
- +10 ;
- +11 ; Ind. Accept-Skip Blanks
- IF +IBMVGRP=4
- DO GRP^IBCNBAC(IBBUFDA,IBGRPDA,1)
- +12 ;
- ACANB ; -- Annual Benefits /awc
- +1 IF +IBGRPDA
- DO ANNBEN^IBCNBCD1(IBBUFDA,IBGRPDA,.IBASAV,.IBQ,.IBERR)
- IF IBQ=U!($DATA(IBERR))!($DATA(DTOUT))
- GOTO ACCPTQ
- +2 ;
- ACCOV ; -- Coverage Limitations /awc
- +1 IF +IBGRPDA
- DO COVLIM^IBCNBCD2(IBBUFDA,IBGRPDA,.IBCSAV,.IBQ,.IBERR)
- IF IBQ=U!($DATA(IBERR))!($DATA(DTOUT))
- GOTO ACCPTQ
- +2 ;
- ACPOL ;
- +1 WRITE @IOF
- SET IBHELP=",POLICY^IBCNBCD("_IBBUFDA_","_IBPOLDA_")"
- +2 IF 'IBPOLDA
- WRITE !,"This will be a New policy for this group and patient.",!
- +3 DO POLICY^IBCNBCD(IBBUFDA,IBPOLDA)
- +4 IF +IBPOLDA
- SET IBACCPT=$$MATCH("PATIENT POLICY")
- if 'IBACCPT
- SET IBPOLDA=0
- IF $DATA(DIRUT)
- GOTO ACCPTQ
- +5 IF +IBPOLDA
- SET IBMVPOL=$$MOVE("PATIENT POLICY",IBHELP)
- IF $DATA(DIRUT)!(IBMVPOL="")
- GOTO ACCPTQ
- +6 IF 'IBPOLDA
- SET IBNEWPOL=$$NEW("PATIENT POLICY")
- SET IBMVPOL=3
- IF 'IBNEWPOL
- GOTO ACCPTQ
- +7 ;
- +8 ; Ind. Accept-Skip Blanks
- IF +IBMVPOL=4
- DO POLICY^IBCNBAC(IBBUFDA,IBPOLDA,1)
- +9 ;
- ACSUB ; -- Subscriber screens
- +1 WRITE @IOF
- +2 SET IBMVSUB="0^NO CHANGE"
- SET (IBFNAM,IBVAL,IBHOLD,IBXHOLD)=""
- SET IBRIEN=0
- +3 SET IBSIEN=$SELECT(+IBPOLDA:IBPOLDA_","_DFN_",",1:0)
- +4 ;
- +5 SET IBSEL=+$$SUASK(.IBVAL)
- IF $DATA(DUOUT)!($DATA(DTOUT))
- GOTO ACCPTQ
- +6 ;
- +7 IF IBSEL'=1&(IBSEL'=18)
- WRITE !,!,"*** Warning - Please Complete Subscriber Update Fields Manually via the Patient Insurance File."
- DO WAIT
- GOTO ACEB
- +8 IF '$TEST
- Begin DoDot:1
- +9 ;
- +10 IF 'IBPOLDA
- SET IBMVSUB=3
- WRITE !,"A NEW Subscriber Insurance policy must be created for this group/patient before Subscriber updates.",!
- DO WAIT
- QUIT
- +11 ;
- +12 ; -- display subscriber screens
- +13 DO SBDISP^IBCNBCD4(IBBUFDA,DFN,IBPOLDA,IBSEL,IBRIEN,IBSIEN,.IBFNAM,IBVAL,.IBHOLD,.IBXHOLD)
- IF $DATA(DIERR)
- SET IBOUT=1
- QUIT
- +14 ;
- +15 ; -- display M/O/R/N/I screens
- +16 IF +IBPOLDA
- SET IBACCPT=$$SBMATCH("SUBSCRIBER INSURANCE")
- if 'IBACCPT
- SET IBPOLDA=0
- IF $DATA(DIRUT)
- SET IBOUT=1
- QUIT
- +17 IF +IBPOLDA
- SET IBMVSUB=$$SBMOVE("SUBSCRIBER INSURANCE")
- IF $DATA(DIRUT)!(IBMVSUB="")
- SET IBOUT=1
- QUIT
- +18 ;
- +19 ; Ind. Accept-Skip Blanks
- IF +IBMVSUB=4
- DO SUB^IBCNBAC(1,IBFNAM,.IBHOLD,.IBXHOLD)
- End DoDot:1
- IF IBOUT!($DATA(DTOUT))
- GOTO ACCPTQ
- +20 ;
- ACEB ;
- +1 WRITE @IOF
- +2 DO ELIG^IBCNBCD(IBBUFDA,IBPOLDA)
- SET IBELIG=$$REPL()
- IF $DATA(DIRUT)
- GOTO ACCPTQ
- +3 ;
- CHECK ; display changes that will be made and ask user for confirmation
- +1 WRITE @IOF
- +2 ;
- +3 IF +IBINSDA
- SET IBX="The Buffer data will "_$PIECE(IBMVINS,U,2)_" the existing Insurance Company data."
- +4 IF +IBINSDA
- IF 'IBMVINS
- SET IBX="There will be "_$PIECE(IBMVINS,U,2)_" to the existing Insurance Company data."
- +5 IF 'IBINSDA
- SET IBX=$PIECE(^IBA(355.33,IBBUFDA,20),U,1)_" will be added as a NEW Insurance Company."
- +6 WRITE !!,$GET(IORVON)_"STEP 1: Insurance Company"_$JUSTIFY("",55)_$GET(IORVOFF)
- WRITE !,IBX
- +7 ;
- +8 IF +IBGRPDA
- SET IBX="The Buffer data will "_$PIECE(IBMVGRP,U,2)_" the existing Group/Plan data."
- +9 IF +IBGRPDA
- IF 'IBMVGRP
- SET IBX="There will be "_$PIECE(IBMVGRP,U,2)_" to the existing Group/Plan data."
- +10 IF 'IBGRPDA
- SET IBX="A NEW Group Plan will be added to this Insurance Company."
- +11 WRITE !!,$GET(IORVON)_"STEP 2: Group/Plan"_$JUSTIFY("",62)_$GET(IORVOFF)
- WRITE !,IBX
- +12 ;
- +13 ; AWC/ Annual Benefits
- +14 IF 'IBPOLDA
- SET IBX="There is no Patient Insurance Policy for this patient and this Group/Plan."
- +15 IF '$TEST
- IF +IBPOLDA
- Begin DoDot:1
- +16 IF IBASAV
- SET IBX="Edited Data was SAVED into the Annual Benefits File."
- QUIT
- +17 SET IBX="No Edits made/saved. No data saved into the Annual Benefits File."
- End DoDot:1
- +18 WRITE !!,$GET(IORVON)_"STEP 3: Annual Benefits"_$JUSTIFY("",57)_$GET(IORVOFF)
- WRITE !,IBX
- +19 ;
- +20 ; AWC/ Coverage Limitations
- +21 IF 'IBPOLDA
- SET IBX="There is no Patient Insurance Policy for this patient and this Group/Plan."
- +22 IF '$TEST
- IF +IBPOLDA
- Begin DoDot:1
- +23 IF IBCSAV
- SET IBX="Edited data was SAVED into the Coverage Limitations File."
- QUIT
- +24 SET IBX="No Edits made/saved. No data saved into the Coverage Limitations File."
- End DoDot:1
- +25 WRITE !!,$GET(IORVON)_"STEP 4: Coverage Limitation"_$JUSTIFY("",53)_$GET(IORVOFF)
- WRITE !,IBX
- +26 ;
- +27 ; AWC/ Moved Patient Policy to Step 5
- +28 IF +IBPOLDA
- SET IBX="The Buffer data will "_$PIECE(IBMVPOL,U,2)_" the existing Policy data."
- +29 IF +IBPOLDA
- IF 'IBMVPOL
- SET IBX="There will be "_$PIECE(IBMVPOL,U,2)_" to the existing Policy data."
- +30 IF 'IBPOLDA
- SET IBX="A NEW Patient Policy will be added for this patient and this Group/Plan."
- +31 WRITE !!,$GET(IORVON)_"STEP 5: Patient Policy"_$JUSTIFY("",58)_$GET(IORVOFF)
- WRITE !,IBX
- +32 ;
- +33 ; AWC/ Subscriber
- +34 IF +IBPOLDA
- SET IBX="The Patient Registration data will "_$PIECE(IBMVSUB,U,2)_" the existing Patient Insurance data."
- +35 IF +IBPOLDA
- IF 'IBMVSUB
- SET IBX="There will be "_$PIECE(IBMVSUB,U,2)_" to the existing Patient Insurance data."
- +36 IF 'IBPOLDA
- SET IBX="A NEW Patient Insurance Policy will be added for this patient and this Group/Plan."
- +37 WRITE !!,$GET(IORVON)_"STEP 6: Subscriber Update"_$JUSTIFY("",55)_$GET(IORVOFF)
- WRITE !,IBX
- +38 IF IBSEL'=1&(IBSEL'=18)
- SET IBX="Please Complete Subscriber Update Fields Manually via the Patient Insurance File."
- WRITE !,IBX
- +39 ;
- +40 ; AWC/ Moved Eligibility/Benefits to Step 7
- +41 SET IBX="The Buffer data will"_$SELECT(IBELIG:"",1:" not")_" replace the existing EB data."
- +42 WRITE !!,$GET(IORVON)_"STEP 7: Eligibility/Benefits"_$JUSTIFY("",52)_$GET(IORVOFF)
- WRITE !,IBX
- +43 ;
- +44 IF +IBINSDA
- IF $PIECE(IBMVINS,U,1)=0
- IF +IBGRPDA
- IF $PIECE(IBMVGRP,U,1)=0
- IF +IBPOLDA
- IF $PIECE(IBMVPOL,U,1)=0
- IF $PIECE(IBMVSUB,U,1)=0
- IF +IBELIG=0
- WRITE !!!,"This would result in No Change to the existing Insurance data. Process aborted."
- DO WAIT
- GOTO ACCPTQ
- +45 ;
- +46 IF '$$OK
- GOTO ACCPTQ
- +47 ;
- PROCESS ; process all changes selected by user, add/edit insurance files based on buffer data, cleanup, ...
- +1 ;
- +2 ;IB*737/CKB - IBBUFABORT is Newed in ACCEPT^IBCNBLA1
- +3 DO ACCEPT^IBCNBAR(IBBUFDA,DFN,IBINSDA,IBGRPDA,.IBPOLDA,IBMVINS,IBMVGRP,IBMVPOL,IBMVSUB,IBNEWINS,IBNEWGRP,IBNEWPOL,IBELIG,IBSEL,IBRIEN,.IBSIEN,IBFNAM,IBVAL,.IBHOLD,.IBXHOLD)
- +4 ;IB*737/CKB
- IF 'IBBUFABORT
- SET IBDONE=1
- +5 ;
- ACCPTQ ;
- +1 QUIT IBDONE
- +2 ;
- LKPYR(IBGRPDA,ABYR) ; Look up year
- +1 NEW X,Y,DA,DR,DIC
- +2 SET DA=IBGRPDA
- SET DIC="^IBA(355.4,"
- SET DIC(0)="MZ"
- SET X=$PIECE(ABYR,U,2)
- +3 DO ^DIC
- +4 QUIT +Y
- +5 ;
- MATCH(IBDESC) ; ask the user if the buffer entry is a match with the selected insurance file entry
- +1 ; returns 1 if there is a match, 0 otherwise
- +2 NEW DIR,X,Y,IBX
- SET IBX=0
- +3 SET DIR("?")="Enter Yes if this existing "_IBDESC_" corresponds to the buffer entry "_IBDESC_". Enter No to add new "_IBDESC_"."
- +4 SET DIR("?",1)="Entering Yes will match this existing "_IBDESC_" with the buffer entry,"
- +5 SET DIR("?",2)="no new "_IBDESC_" will be created. Any existing "_IBDESC_" data"
- +6 SET DIR("?",3)="changes based on the Buffer data will be applied to this "_IBDESC_"."
- +7 SET DIR("?",4)="Enter No to create a new "_IBDESC_" if the Buffer entry's "
- +8 SET DIR("?",5)=IBDESC_" data does not match any existing "_IBDESC_"."
- SET DIR("?",6)=""
- +9 ;
- +10 WRITE !
- SET DIR(0)="YO"
- SET DIR("A")="Is this the correct "_IBDESC_" to match with this Buffer entry"
- DO ^DIR
- IF Y=1
- SET IBX=1
- +11 QUIT IBX
- +12 ;
- SBMATCH(IBDESC) ; ask the user if the Patient Registration entry is a match with the selected insurance file entry
- +1 ; returns 1 if there is a match, 0 otherwise
- +2 NEW DIR,X,Y,IBX
- SET IBX=0
- +3 SET DIR("?")="Enter Yes if this existing "_IBDESC_" corresponds to the Patient Registration entry. Enter No if not."
- +4 SET DIR("?",1)="Entering Yes will match this existing "_IBDESC_" with the Patient Registration entry,"
- +5 SET DIR("?",2)="no new "_IBDESC_" will be created. Any existing "_IBDESC_" data"
- +6 SET DIR("?",3)="changes based on the Patient Registration data will be applied to this "_IBDESC_"."
- +7 SET DIR("?",4)="Enter No to create a new "_IBDESC_" policy if the Patient Registration entry's "
- +8 SET DIR("?",5)=IBDESC_" data does not match any existing "_IBDESC_"."
- SET DIR("?",6)=""
- +9 ;
- +10 WRITE !
- SET DIR(0)="YO"
- SET DIR("A")="Is this the correct "_IBDESC_" to match with this Patient Registration entry"
- DO ^DIR
- IF Y=1
- SET IBX=1
- +11 QUIT IBX
- +12 ;
- MOVE(IBDESC,IBHELP) ; ask the user what method they want to use to transfer buffer data to the insurance files
- +1 ; returns 1^merge, 2^overwrite, 3^replace, 4^individually accept (skip blanks),
- +2 ; 0^no change,
- +3 ; or "" if none of the methods was chosen
- +4 NEW DIR,X,Y,IBX
- SET IBX=""
- +5 SET DIR("?")="^D HELP^IBCNBUH,WAIT^IBCNBAA"_$GET(IBHELP)
- SET DIR("??")="^D HELP2^IBCNBUH,WAIT^IBCNBAA"_$GET(IBHELP)
- +6 SET DIR("A")="Select the method to update the "_IBDESC
- +7 ; DAOU/BHS - 08/28/2002 - Added INDIVIDUALLY ACCEPT methods
- +8 WRITE !
- SET DIR(0)="SOB^M:MERGE;O:OVERWRITE;R:REPLACE;N:NO CHANGE;I:INDIVIDUALLY ACCEPT (SKIP BLANKS)"
- DO ^DIR
- +9 SET IBX=$SELECT(Y="M":1,Y="O":2,Y="R":3,Y="I":4,Y="N":0,1:"")
- IF IBX'=""
- SET IBX=IBX_U_$GET(Y(0))_$SELECT(+IBX=1:" with",1:"")
- +10 QUIT IBX
- +11 ;
- SBMOVE(IBDESC) ; ask the user what method they want to use to transfer buffer data to the insurance files
- +1 ; returns 1^merge, 2^overwrite, 3^replace, 4^individually accept (skip blanks),
- +2 ; 0^no change,
- +3 ; or "" if none of the methods was chosen
- +4 NEW DIR,X,Y,IBX
- SET IBX=""
- +5 SET DIR("?")="^D HELP^IBCNBUH,WAIT^IBCNBAA"_","_"SBDISP^IBCNBCD4(IBBUFDA,DFN,IBPOLDA,IBSEL,IBRIEN,IBSIEN,.IBFNAM,IBVAL,.IBHOLD,.IBXHOLD)"
- +6 SET DIR("??")="^D HELP2^IBCNBUH,WAIT^IBCNBAA"_","_"SBDISP^IBCNBCD4(IBBUFDA,DFN,IBPOLDA,IBSEL,IBRIEN,IBSIEN,.IBFNAM,IBVAL,.IBHOLD,.IBXHOLD)"
- +7 SET DIR("A")="Select the method to update the "_IBDESC
- +8 ; DAOU/BHS - 08/28/2002 - Added INDIVIDUALLY ACCEPT methods
- +9 WRITE !
- SET DIR(0)="SOB^M:MERGE;O:OVERWRITE;R:REPLACE;N:NO CHANGE;I:INDIVIDUALLY ACCEPT (SKIP BLANKS)"
- DO ^DIR
- +10 SET IBX=$SELECT(Y="M":1,Y="O":2,Y="R":3,Y="I":4,Y="N":0,1:"")
- IF IBX'=""
- SET IBX=IBX_U_$GET(Y(0))_$SELECT(+IBX=1:" with",1:"")
- +11 QUIT IBX
- +12 ;
- NEW(IBDESC) ; ask user if they want to add a new entry to the insurance files (36, 355.3, or 2.312)
- +1 ; returns 1 if Yes create a new entry, 0 otherwise
- +2 NEW DIR,X,Y,IBX
- SET IBX=0
- +3 ;
- +4 ; The following was changed with patch IB*2.0*506
- +5 SET DIR("?")="Enter Yes to create a new "_IBDESC_". Enter No to stop this process."
- +6 SET DIR("?",1)="Enter Yes to create a new "_IBDESC_" in the Insurance files for"
- +7 SET DIR("?",2)="this Buffer entry only if no existing "_IBDESC_" could be found"
- +8 SET DIR("?",3)="that matches this buffer entry."
- SET DIR("?",4)=""
- +9 WRITE !
- SET DIR(0)="YO"
- SET DIR("A")="NO "_IBDESC_" Selected, do you need a New "_IBDESC
- DO ^DIR
- IF +Y=1
- SET IBX=1
- +10 ;
- +11 ;I IBDESC="INSURANCE COMPANY",'$D(^XUSEC("IB INSURANCE COMPANY ADD",DUZ)) W !!,"Sorry, but you do not have the required privileges to add",!,"new Insurance Companies." D WAIT G NEWQ
- +12 IF IBX=1
- Begin DoDot:1
- +13 IF IBDESC="INSURANCE COMPANY"
- Begin DoDot:2
- +14 IF '$DATA(^XUSEC("IB INSURANCE COMPANY EDIT",DUZ))
- WRITE !!,"A Supervisor will need to add the "_IBDESC_" before processing can",!,"continue."
- SET IBX=0
- DO WAIT
- QUIT
- +15 WRITE !!,"You must create an "_IBDESC_" first."
- SET IBX=0
- DO WAIT
- End DoDot:2
- QUIT
- +16 IF IBDESC="GROUP/PLAN"
- Begin DoDot:2
- +17 IF '$DATA(^XUSEC("IB GROUP PLAN EDIT",DUZ))
- WRITE !!,"A Supervisor will need to add the "_IBDESC_" before processing can continue."
- SET IBX=0
- DO WAIT
- QUIT
- +18 WRITE !!,"You must create a "_IBDESC_" first."
- SET IBX=0
- DO WAIT
- End DoDot:2
- QUIT
- End DoDot:1
- GOTO NEWQ
- +19 ;/IB*2.0*506 End
- NEWQ QUIT IBX
- +1 ;
- REPL() ; ask user if they want to replace eligibility/benefits data in pt. insuarance
- +1 NEW DIR,X,Y,IBX
- +2 SET IBX=0
- +3 SET DIR(0)="YO"
- SET DIR("A")="Replace the Pt's Eligibility/Benefits data"
- SET DIR("B")="YES"
- +4 SET DIR("?")="Enter Yes to replace existing Eligibility/Benefits data with one from eIV response."
- +5 WRITE !
- DO ^DIR
- IF +Y=1
- SET IBX=1
- +6 QUIT IBX
- +7 ;
- OK() ; ask the user if the buffer data should be moved to the insurance files
- +1 ; returns 1 if yes, 0 otherwise
- +2 NEW DIR,X,Y,IBX
- SET IBX=0
- WRITE !!!
- +3 SET DIR("?")="Enter Yes to accept/verify the buffer data and move it to the insurance files. Enter No to stop this process."
- +4 SET DIR("?",1)="Entering Yes will cause several things to happen:"
- +5 SET DIR("?",2)=" 1 - the above changes will be completed and the Insurance files updated with"
- +6 SET DIR("?",3)=" the buffer data."
- +7 SET DIR("?",4)=" 2 - the Insurance entries modified or added will be flagged as verified."
- +8 SET DIR("?",5)=" 3 - most of the insurance and patient related information in the buffer entry"
- +9 SET DIR("?",6)=" will be deleted, leaving only a stub entry for reporting purposes."
- SET DIR("?",7)=""
- +10 SET DIR(0)="YO"
- SET DIR("A")="Is this Correct, update the existing Insurance files now"
- DO ^DIR
- IF Y=1
- SET IBX=1
- +11 QUIT IBX
- +12 ;
- WAIT NEW DIR,DIRUT,DUOUT,DTOUT,X,Y
- WRITE !!
- SET DIR(0)="E"
- SET DIR("A")="Enter RETURN to continue"
- DO ^DIR
- WRITE !!
- +1 QUIT
- +2 ;
- SUASK(IBVAL) ; ask user to select Pt. Relationship to Insured
- +1 NEW X,Y,DIR,IBF
- +2 WRITE !
- +3 SET IBF=$PIECE($GET(^DD(2.312,4.03,0)),U,3)
- +4 ;
- +5 SET DIR(0)="SAO^"_IBF
- +6 SET DIR("A")="Select the Patient Relationship to Subscriber: "
- +7 SET DIR("?",1)=" Enter the code which best describes this patient's relationship"
- +8 SET DIR("?")=" to the person who holds this insurance policy (or insured)."
- +9 DO ^DIR
- IF +Y
- SET IBVAL=Y_U_$PIECE($PIECE(IBF,Y_":",2),";")
- +10 QUIT +Y
- +11 ;
- READ(IBRTYP,IBPROM,IBDFLT,IBHELP,IBSCRN) ; Reader that will returns a response to user input
- +1 ; Input:
- +2 ; IBRTYP : Read Type and Input modifiers^Input Parameters^Input Transform (Required)
- +3 ; IBPROM : Prompt text that user will see
- +4 ; IBDFLT : Default response
- +5 ; IBHELP : Help text to display
- +6 ; IBSCRN : Screen for pointer, set-of-code, and list/range reads
- +7 ;
- +8 NEW DIR,X,Y
- +9 ;
- +10 WRITE !
- +11 ;
- +12 SET DIR(0)=IBRTYP
- +13 if $GET(IBPROM)]""
- SET DIR("A")=IBPROM
- +14 if $GET(IBDFLT)]""
- SET DIR("B")=IBDFLT
- +15 if $GET(IBHELP)]""
- SET DIR("?")=IBHELP
- +16 if $GET(IBSCRN)]""
- SET DIR("S")=IBSCRN
- +17 DO ^DIR
- +18 ;
- +19 ; -- Return Y value concatonated with the .01 value of the zero node if look-up was successful
- +20 ; -- <or> "@" if user deleted entry
- +21 ; -- <or> -1, <or> "" if look-up not successful
- +22 QUIT $SELECT((Y'=-1&(Y]"")&($EXTRACT(Y)'=U))&($LENGTH($GET(Y),U)'=2):Y_U_$GET(Y(0),Y),$GET(X)="@":"@",1:Y)