source: WorldVistAEHR/trunk/r/HOSPITAL_BASED_HOME_CARE-HBH/HBHCAPPT.m@ 1704

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

initial load of WorldVistAEHR
File size: 6.1 KB
Line 
1HBHCAPPT ; LR VAMC(IRMS)/MJT-HBHC batch job to create ^HBHC(632) (visit) nodes from PCE module info => patient, appointment date/time, hospital location (clinic), prov, DX code(s), & CPT code(s), calls ^HBHCCAN, HBHCAPP1 ; Jul 2000
2 ;;1.0;HOSPITAL BASED HOME CARE;**6,8,10,12,13,15,16,14**;NOV 01, 1993
3 ; Daily auto-queued option, also called from ^HBHCFILE, HBHCLSDT, last date to include in transmit set up in ^HBHCFILE
4 D START^HBHCAPP1
5SCAN ; Scan
6 N HBHCQRY
7 D OPEN^SDQ(.HBHCQRY)
8 D INDEX^SDQ(.HBHCQRY,"DATE/TIME","SET")
9 D DATE^SDQ(.HBHCQRY,HBHCBGDT,HBHCLSDT,"SET")
10 D SCANCB^SDQ(.HBHCQRY,"D CB^HBHCAPPT(Y,Y0,.SDSTOP)","SET")
11 D ACTIVE^SDQ(.HBHCQRY,"TRUE","SET")
12 D SCAN^SDQ(.HBHCQRY,"FORWARD")
13 D CLOSE^SDQ(.HBHCQRY)
14 I ($D(^HBHC(634.1,"B")))!($D(^HBHC(634.2,"B")))!($D(^HBHC(634.3,"B")))!($D(^HBHC(634.5,"B"))) D MAIL^HBHCAPP1
15 ; Delete File Update in Progress Flag
16 S $P(^HBHC(631.9,1,0),U,8)=""
17EXIT ; Exit module
18 D EXIT^HBHCAPP1
19 Q
20CB(HBHCOEP,HBHCSCE0,HBHCSTOP) ;
21 ; Omit Child encounter, (child if Parent Encounter field contains data)
22 Q:$P(HBHCSCE0,U,6)]""
23 ; Quit if invalid status for HBHC purposes
24 Q:($P(HBHCSCE0,U,12)=4)!($P(HBHCSCE0,U,12)=5)!($P(HBHCSCE0,U,12)=6)!($P(HBHCSCE0,U,12)=7)!($P(HBHCSCE0,U,12)=9)!($P(HBHCSCE0,U,12)=10)!($P(HBHCSCE0,U,12)=11)!($P(HBHCSCE0,U,12)=13)
25 ; Clinic missing
26 Q:$P(HBHCSCE0,U,4)=""
27 ; Include only HBHC clinics
28 Q:'$D(^HBHC(631.6,"B",$P(HBHCSCE0,U,4)))
29 S HBHCCLN=$P(HBHCSCE0,U,4)
30 D VERIFY I 'HBHCFLG D PROCESS D:$D(HBHCMSG) ERROR^HBHCAPP1
31 Q
32VERIFY ; Verify record doesn't already exist in ^HBHC(632) file
33 S HBHCFLG=0,HBHCDPT=$P(HBHCSCE0,U,2),HBHCAPDT=$P(HBHCSCE0,U)
34 I HBHCDPT="" S HBHCFLG=1 Q
35 S HBHCBXRF=0 F S HBHCBXRF=$O(^HBHC(632,"B",HBHCDPT,HBHCBXRF)) Q:(HBHCBXRF'>0)!(HBHCFLG) S:($D(^HBHC(632,"AE",HBHCOEP)))&(HBHCAPDT=$P(^HBHC(632,HBHCBXRF,0),U,2))&('$D(^HBHC(632,"AC","C",HBHCBXRF))) HBHCFLG=1
36 Q
37PROCESS ; Process provider, diagnosis (DX), & CPT code data
38 ; Dx
39 K HBHCDXL,HBHCDX
40 D GETDX^SDOE(HBHCOEP,"HBHCDXL")
41 S HBHCCNT=1 F HBHCI=1:1:HBHCDXL S HBHCDX(HBHCI)=""
42 S HBHCDFN=0 F S HBHCDFN=$O(HBHCDXL(HBHCDFN)) Q:(HBHCDFN'>0)!(HBHCCNT>HBHCDXL) S:$P(HBHCDXL(HBHCDFN),U,12)="P" HBHCDX(1)=$P(HBHCDXL(HBHCDFN),U) S:$P(HBHCDXL(HBHCDFN),U,12)="S" HBHCCNT=HBHCCNT+1,HBHCDX(HBHCCNT)=$P(HBHCDXL(HBHCDFN),U)
43 ; Dx missing
44 I (+$G(HBHCDXL)'>0) S HBHCMSG=3 Q
45 ; provider, use Encounter Provider (field 1204, file 9000010.18) or V Provider (9000010.06) (if encounter provider doesn't exist), each provider within encounter will become a separate HBHC Visit record
46 K HBHCPRV1,HBHCPRVL
47 D GETPRV^SDOE(HBHCOEP,"HBHCPRVL")
48 S (HBHCPCNT,HBHCDFN,HBHCONE)=0 F S HBHCDFN=$O(HBHCPRVL(HBHCDFN)) Q:HBHCDFN'>0 S HBHCPRV=$P(HBHCPRVL(HBHCDFN),U) D CHECK S:HBHCONE=1 HBHCPCNT=HBHCPCNT+1,HBHCPRV1(HBHCPRV)=""
49 ; Provider missing
50 I (+$G(HBHCPRVL)'>0) S HBHCMSG=2 Q
51 ; HBHC provider missing
52 I HBHCONE=0 S HBHCMSG=11 Q
53 ; Multiple HBHC provider numbers
54 I HBHCONE>1 S HBHCMSG=12 Q
55 ; CPT Code
56 K HBHCCPTL,HBHCPRV
57 D GETCPT^SDOE(HBHCOEP,"HBHCCPTL")
58 S (HBHCDFN,HBHCONE)=0 F S HBHCDFN=$O(HBHCCPTL(HBHCDFN)) Q:(HBHCDFN'>0)!($D(HBHCMSG)) S HBHCPRV=$P($G(HBHCCPTL(HBHCDFN,12)),U,4) D:HBHCPRV]"" CHECK S HBHCNBR=$P(HBHCCPTL(HBHCDFN,0),U,16) D PROV
59 ; Provider mismatch
60 Q:$D(HBHCMSG)
61 ; Provider ambiguous
62 I $D(HBHCPRV("ZZ")) S HBHCMSG=5 Q
63 ; CPT Code missing
64 I (+$G(HBHCCPTL)=0) S HBHCMSG=4 Q
65 ; outpatient encounter must have 'checked-out' status (2) to ensure provider, Dx, & CPT data exist, or inpatient status (8)
66 I ($P(HBHCSCE0,U,12)'=2)&($P(HBHCSCE0,U,12)'=8) S HBHCMSG=1 Q
67SET ; Set node, call ^DIK to set cross-refs in ^HBHC(632) (visit) file
68 S HBHCPRV="" F S HBHCPRV=$O(HBHCPRV(HBHCPRV)) Q:HBHCPRV="" D SETLOOP
69 Q
70SETLOOP ; Set loop
71 S HBHC="" F S HBHC=$O(^HBHC(631.4,"C",HBHCPRV,HBHC)) Q:(HBHC="")!('$D(^HBHC(631.4,"AC",1,HBHC)))
72 L +^HBHC(632,0) F S HBHCDFN=$P(^HBHC(632,0),U,3)+1,$P(^HBHC(632,0),U,3)=HBHCDFN Q:'$D(^HBHC(632,HBHCDFN,0))
73 S $P(^HBHC(632,0),U,4)=$P(^HBHC(632,0),U,4)+1 L -^HBHC(632,0)
74 L +^HBHC(632,HBHCDFN,2) S HBHCCPT=""
75 F S HBHCCPT=$O(HBHCPRV(HBHCPRV,HBHCCPT)) Q:HBHCCPT="" S HBHCNBR="" F S HBHCNBR=$O(HBHCPRV(HBHCPRV,HBHCCPT,HBHCNBR)) Q:HBHCNBR="" D SETCPT S HBHCK=0 F S HBHCK=$O(HBHCPRV(HBHCPRV,HBHCCPT,HBHCNBR,HBHCK)) Q:HBHCK'>0 D SETMOD
76 L -^HBHC(632,HBHCDFN,2)
77 L +^HBHC(632,HBHCDFN,3) K DD,DO S DIC="^HBHC(632,",DIC(0)="L",DIC("P")=$P(^DD(632,33,0),U,2),DA(1)=HBHCDFN,DIC=DIC_DA(1)_",3,",HBHCI="" F S HBHCI=$O(HBHCDX(HBHCI)) Q:HBHCI="" S X=HBHCDX(HBHCI) D FILE^DICN
78 L -^HBHC(632,HBHCDFN,3)
79 L +^HBHC(632,HBHCDFN,0) S ^HBHC(632,HBHCDFN,0)=HBHCDPT_U_HBHCAPDT_U_HBHCCLN_U_HBHC_U_U_U_U_"N"_U_U_U_U_U_U_U_U_U_U_U_U_U_U_HBHCOEP L -^HBHC(632,HBHCDFN,0)
80 K DIK S DIK="^HBHC(632,",DA=HBHCDFN D IX^DIK K DIK
81 Q
82CHECK ; Check to ensure provider only has 1 HBHC Provider Number (631.4) or if > 1, has others flagged as Inactive Provider Numbers
83 S (HBHCONE,HBHCIEN)=0 F S HBHCIEN=$O(^HBHC(631.4,"C",HBHCPRV,HBHCIEN)) Q:(HBHCIEN'>0)!(HBHCONE>1) S:'$D(^HBHC(631.4,"AC",1,HBHCIEN)) HBHCONE=HBHCONE+1
84 Q
85PROV ; Encounter provider & CPT code processing
86 S:HBHCPCNT=1 HBHCTXT="",HBHCTXT=$O(HBHCPRV1(HBHCTXT))
87 F HBHCJ=1:1:HBHCNBR D:HBHCPRV="" SUB1 D:HBHCPRV]"" SUB2
88 Q
89SUB1 ; Subroutine 1 for encounter provider & CPT code processing
90 S HBHCPRV($S(HBHCPCNT=1:HBHCTXT,1:"ZZ"),$P(HBHCCPTL(HBHCDFN,0),U),HBHCJ)=""
91 S HBHCK=0 F S HBHCK=$O(HBHCCPTL(HBHCDFN,1,HBHCK)) Q:HBHCK'>0 S HBHCPRV($S(HBHCPCNT=1:HBHCTXT,1:"ZZ"),$P(HBHCCPTL(HBHCDFN,0),U),HBHCJ,HBHCK)=HBHCCPTL(HBHCDFN,1,HBHCK,0)
92 Q
93SUB2 ; Subroutine 2 for encounter provider & CPT code processing
94 I (HBHCONE=1)&($D(HBHCPRV1(HBHCPRV))) S HBHCPRV(HBHCPRV,$P(HBHCCPTL(HBHCDFN,0),U),HBHCJ)="",HBHCK=0 F S HBHCK=$O(HBHCCPTL(HBHCDFN,1,HBHCK)) Q:HBHCK'>0 S HBHCPRV(HBHCPRV,$P(HBHCCPTL(HBHCDFN,0),U),HBHCJ,HBHCK)=HBHCCPTL(HBHCDFN,1,HBHCK,0)
95 S:'$D(HBHCPRV1(HBHCPRV)) HBHCMSG=13
96 Q
97SETCPT ; Set CPT multiple
98 K DD,DO S DIC="^HBHC(632,",DIC(0)="L",DIC("P")=$P(^DD(632,32,0),U,2),DA(1)=HBHCDFN,X=HBHCCPT,DIC=DIC_DA(1)_",2," D FILE^DICN
99 ; Set up for CPT Modifier update
100 S DA=+Y,DA(2)=DA(1),DA(1)=DA
101 K DD,DO S DIC("P")=$P(^DD(632.032,1,0),U,2),DIC=DIC_DA_",1,"
102 Q
103SETMOD ; Set CPT Modifier multiple
104 S X=HBHCPRV(HBHCPRV,HBHCCPT,HBHCNBR,HBHCK) D FILE^DICN S DA=+Y
105 Q
Note: See TracBrowser for help on using the repository browser.