source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSOK.m@ 1604

Last change on this file since 1604 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.2 KB
Line 
1IBCNSOK ;ALB/AAS - Patient Insurance consistency checker ; 2/22/93
2 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5% I '$D(DT) D DT^DICRW
6 K ^TMP("IBCNS-ERR",$J)
7 ;
8 W !!,"Check Patient file Insurance Type Group Plan consistency"
9 W !!,"I'm going to check the Insurance company for each patient policy with the",!,"Insurance company in the associated Group Plan file."
10 W !!,"This will take a while, please queue this job to a device. I'll print",!,"a report when I'm done.",!!
11 ;
12UP S IBUPDAT=0
13 S DIR(0)="Y",DIR("A")="Update any Inconsistencies",DIR("B")="NO"
14 S DIR("?")="Enter YES if you want any inconsistencies updated, enter NO if you just want the report."
15 D ^DIR K DIR
16 S IBUPDAT=+Y I $D(DIRUT) G END
17 ;
18DEV W !! S %ZIS="QM" D ^%ZIS G:POP END
19 I $D(IO("Q")) K IO("Q") D G END
20 .S ZTRTN="DQ^IBCNSOK",ZTDESC="IB - v2 PATIENT FILE DOUBLE CHECK",ZTIO="",ZTSAVE("IB*")=""
21 .W ! D ^%ZTLOAD D HOME^%ZIS
22 .I $D(ZTSK) W !," Patient file update queued as task ",ZTSK K ZTSK Q
23 ;
24 D DQ G END
25 Q
26 ;
27END K ^TMP("IBCNS-ERR",$J)
28 I $D(ZTQUEUED) S ZTREQ="@" Q
29 D ^%ZISC
30 K %ZIS,DIRUT,I,J,X,Y,DA,DR,DIC,DIE,DIR,IBCPOL,IBCOPOL2,IBCDFND,NODE,IBI,IBCNTI,IBCNTP,IBCNTPP,IBUPDT,IBCDFN
31 Q
32 ;
33DQ ; -- entry point from task man
34 U IO
35 S IBQUIT=0
36 D NOW^%DTC S IBSPDT=%
37 I '$D(ZTQUEUED) D
38 .W !!," I'll write a dot for each 100 entries"
39 .W:IBUPDAT !," and a + for each entry updated"
40 .W !," Start time: " S Y=IBSPDT D DT^DIQ
41 N DFN,IBI,IBCPOL,IBCDFND,DA,DR,DIE,DIC,IBCNT,IBCNTP,IBCNTPP,IBCNTI,IBCDFN
42 S (IBCNT,IBCNTP,IBCNTPP,IBCNTI,DFN)=0
43 ;
44 F S DFN=$O(^DPT(DFN)) Q:'DFN S IBCNT=IBCNT+1,IBCDFN=0 S:$O(^DPT(DFN,.312,IBCDFN)) IBCNTI=IBCNTI+1 F S IBCDFN=$O(^DPT(DFN,.312,IBCDFN)) Q:'IBCDFN D
45 .I '$D(ZTQUEUED) W:'(IBCNTPP#100) "."
46 .S IBCNTPP=IBCNTPP+1
47 .S IBCDFND=$G(^DPT(DFN,.312,IBCDFN,0))
48 .I IBCDFND="",$D(^DPT(DFN,.312,IBCDFN)) D ERR3
49 .;
50 .S IBCPOL=+$G(^IBA(355.3,+$P(IBCDFND,"^",18),0))
51 .I '$P(IBCDFND,"^",18) D ERR1 Q ; no group plan field
52 .I +IBCPOL'=+IBCDFND D ERR2 Q ; ins. companies don't match
53 .Q
54 ;
55 D REPORT G END
56 Q
57 ;
58ERR1 ; -- no group plan pointer
59 S NODE="IBCNS-ERR1" D FIX
60 Q
61 ;
62ERR2 ; -- wrong insurance pointer
63 S NODE="IBCNS-ERR2" D FIX
64 Q
65 ;
66ERR3 ; -- dangle insurance node left
67 S NODE="IBCNS-ERR3" D SET
68 I IBUPDAT K ^DPT(DFN,.312,IBCDFN) W:'$D(ZTQUEUED) "+"
69 Q
70 ;
71FIX ; -- reset pointer correctly
72 S IBCPOL2=IBCPOL
73 ;
74 S IBCPOL=$$CHIP^IBCNSU(IBCDFND)
75 Q:'IBCPOL
76 Q:+IBCDFND'=+$G(^IBA(355.3,+IBCPOL,0)) ; patient ins. and policy must have same ins. company file.
77 S DA=IBCDFN,DA(1)=DFN,DIE="^DPT("_DFN_",.312,"
78 S DR="1.09////1;.18////"_IBCPOL
79 D:IBUPDAT ^DIE K DA,DR,DIE,DIC W:'$D(ZTQUEUED) "+"
80SET S ^TMP("IBCNS-ERR",$J,$P(^DPT(DFN,0),"^"),DFN,IBCDFN)=IBCPOL2_"^"_IBCPOL_"^"_NODE
81 Q
82 ;
83REPORT ; -- Okay now tell us about the errors
84 D NOW^%DTC S IBHDT=$$FMTE^XLFDT(%),IBPAG=0
85 D HDR
86 S NAME="",NODE="IBCNS-ERR"
87 I '$D(^TMP(NODE,$J)) W !!,"No Errors Found!" Q
88 F S NAME=$O(^TMP(NODE,$J,NAME)) Q:NAME="" D
89 .S DFN=0 F S DFN=$O(^TMP(NODE,$J,NAME,DFN)) Q:'DFN D
90 ..S IBCDFN=0 F S IBCDFN=$O(^TMP(NODE,$J,NAME,DFN,IBCDFN)) Q:'IBCDFN S IBDATA=^(IBCDFN) D ONE
91 Q
92 ;
93ONE ; -- print one line
94 D PID^VADPT
95 W !,$E($P($G(^DPT(DFN,0)),"^"),1,16)_" ("_DFN_")"
96 W ?25,VA("PID")
97 S IBCDFND=$G(^DPT(DFN,.312,IBCDFN,0))
98 W ?39,$E($P($G(^DIC(36,+IBCDFND,0)),"^"),1,25)
99 S IBCPOLD=$G(^IBA(355.3,+IBDATA,0))
100 I +IBCPOLD W ?68,$E($P(IBCPOLD,"^",4)_"("_$P($G(^DIC(36,+IBCPOLD,0)),"^"),1,33)_")"
101 S IBCPOLD=$G(^IBA(355.3,$P(IBDATA,"^",2),0))
102 I +IBCPOLD W ?105,$E($P(IBCPOLD,"^",4)_"("_$P($G(^DIC(36,+IBCPOLD,0)),"^"),1,20)_")"
103 W ?127,$S($G(IBUPDAT):"YES",1:"NO")
104 W !?5,"Error: ",$S($P(IBDATA,"^",3)="IBCNS-ERR1":"Policy is missing group Plan",$P(IBDATA,"^",3)="IBCNS-ERR3":"Dangling insurance node detected",1:"Group Plan is with different insurance company")
105 Q
106 ;
107HDR ; -- Print header
108 Q:IBQUIT
109 I $E(IOST,1,2)="C-",IBPAG D PAUSE^VALM1 I $D(DIRUT) S IBQUIT=1 Q
110 I $E(IOST,1,2)="C-"!(IBPAG) W @IOF
111 S IBPAG=IBPAG+1
112 W !,"Patients with Incorrect Group Plans",?(IOM-33),"Page ",IBPAG," ",IBHDT
113 W !,"PATIENT",?25,"PATIENT ID",?39,"INSURANCE CO.",?68,"OLD PLAN",?105,"NEW PLAN",?127,"UPDATED"
114 W !,$TR($J(" ",IOM)," ","-")
115 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,IBQUIT=1 W !!,"....task stoped at user request" Q
116 Q
Note: See TracBrowser for help on using the repository browser.