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

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

initial load of WorldVistAEHR
File size: 4.4 KB
Line 
1IBCOPV ;ALB/LDB,TMP - ROUTINE TO LIST PATIENT VISITS ;30 APR 90
2 ;;2.0;INTEGRATED BILLING;**27,91,106,124,174,260**;21-MAR-94
3 ;
4 ;MAP TO DGCROPV ... input IBIFN
5 ;
6 N DGNO,DGNO1,IBCBK,IBVAL,IBZ,IBPB,IBOE,IBOE0
7 S IBCOPV=^DGCR(399,IBIFN,"U"),IBCOPV1=$P(IBCOPV,"^"),IBCOPV2=$P(IBCOPV,"^",2) Q:'(IBCOPV1+IBCOPV2)
8 S (DGCNT,DGU)=0 K DGCPT,^UTILITY($J),DGNOD
9 ;
10 S IBVAL("DFN")=DFN,IBVAL("BDT")=IBCOPV1,IBVAL("EDT")=IBCOPV2+.9999
11 S IBCBK="I '$P(Y0,U,6) S ^TMP(""IBOE"",$J,+$P(Y0,U,8),Y)=Y0"
12 K ^TMP("IBOE",$J)
13 S DGNO1=1
14 D SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK,1) K ^TMP("DIERR",$J)
15 F IBZ=9,13 S IBCK(IBZ)=""
16 K ^TMP("IBVIS",$J)
17 S IBZ=0 F S IBZ=$O(^TMP("IBOE",$J,IBZ)) Q:'IBZ S IBOE=0 F S IBOE=$O(^TMP("IBOE",$J,IBZ,IBOE)) Q:'IBOE S IBOE0=$G(^(IBOE)) D
18 . K IBPB
19 . S IBEP=$$BILLCK^IBAMTEDU(IBOE,IBOE0,.IBCK,.IBPB)
20 . I IBEP D CHK(IBOE,IBOE0,.DGNO1)
21 . S ^TMP("IBVIS",$J,+$P(IBOE0,U,5))=""
22 K ^TMP("IBOE",$J),^TMP("IBVIS",$J)
23 D CNT,CNT399 K DIR
24 I 'DGCNT D NOVT^IBCOPV1 Q
25 D PRT^IBCOPV1
26 Q
27 ;
28CHK(IBOE,IBOE0,DGNO1) ;
29 N IBZ,DGFIL,DFN,I,DGNOD
30 S DGFIL=$P("2^409.5^2.101^",U,+$P(IBOE0,U,8)),DFN=$P(IBOE0,U,2),I=+IBOE0
31 ;
32 Q:'DGFIL
33 I '$$BDSRC^IBEFUNC3($P(IBOE0,U,5)) Q ; non-billable visit data source
34 ;
35 I '$D(^TMP("IBVIS",$J,+$P(IBOE0,U,5))) D ;Process visit CPT's only once
36 .N I,I2,I7,IBCPT,IBCPTS,IBZERR
37 .D GETCPT^SDOE(IBOE,"IBCPTS","IBZERR")
38 .Q:'$O(IBCPTS(0)) ;No procedures for this encounter
39 .S I7=IBOE0\1
40 .S I2=0 F S I2=$O(IBCPTS(I2)) Q:'I2 D
41 .. N Z
42 .. S IBCPT=$P(IBCPTS(I2),U)
43 .. F Z=1:1:$P(IBCPTS(I2),U,16) D
44 ... I $L($G(^UTILITY($J,"CPT",I7,DGNO1)))+$L(IBCPT)+1>140 S DGNO1=DGNO1+1
45 ... S ^UTILITY($J,"CPT",I7,DGNO1)=$G(^UTILITY($J,"CPT",I7,DGNO1))_U_IBCPT
46 .S ^UTILITY($J,"CPT",0)="Y"
47 .;
48 .I $O(^UTILITY($J,"CPT",0)) S DGNO=0 F S DGNO=$O(^UTILITY($J,"CPT",I7,DGNO)) Q:DGNO="" S ^UTILITY($J,"CPT1",I7,DGNO)=^UTILITY($J,"CPT",I7,DGNO) D PROD^IBCOPV2
49 ;
50 N IBPRVS,IBPRV,IBI S IBPRV="" D GETPRV^SDOE(IBOE,"IBPRVS")
51 S IBI=0 F S IBI=$O(IBPRVS(IBI)) Q:'IBI I $P(IBPRVS(IBI),U,4)="P" S IBPRV=+IBPRVS(IBI) Q
52 ;
53 S DGNOD=IBOE0
54 D SET K DGNOD
55 Q
56 ;
57TYP ;Q:'$D(DGNOD)
58 ;K DGNO,DGTYP
59 ;I "479"'[$P(DGNOD,U,10) S DGNO=1 Q
60 ;I DGFIL=2,$P(DGNOD,U,10)=9 D Q:$G(DGNO)
61 ;. I $P(DGNOD,U,10)=9 S DGTYP=$P(DGNOD,U,13)
62 ;. I $G(DGTYP),"^6^7^9^"[(U_$P($G(^DIC(8,DGTYP,0)),U,9)_U) S DGNO=1
63 ;I $G(DGTYP) S DGTYP=$E($P($G(^DIC(8,DGTYP,0)),"^"),1,3)
64 ;S:$G(DGTYP)="" DGTYP=$P(DGNOD,U,10)
65 ;S:DGTYP&(DGTYP<9) DGTYP=$E($P($G(^SD(409.1,+DGTYP,0)),U),1,3)
66 ;S DGTYP=$E(DGTYP,1,3)
67 ;;- If the code gets here, DGTYP will either be the first 3 charaters of the
68 ;; appointment type name, the first 3 characters of the eligibility name or a 9
69 ;
70 ; appointment type must be: 4 - Employee, 7 - Collateral of Vet, 8 - Sharing Agreement, or 9 - Regular
71 ; appointment MAS eligibilty must not be: 6 - Other Federal Agency, or 7 - Allied Veteran
72 ;
73 ; if 9-regular or 8-sharing agreement then return appointment eligibilty, otherwise return appointment type
74 ;
75 Q:'$D(DGNOD) K DGNO,DGTYP N IBZT,IBZE,IBZ
76 S DGTYP=""
77 S IBZT=$P(DGNOD,U,10) I "4789"'[IBZT S DGNO=1 Q
78 S IBZE=$P(DGNOD,U,13),IBZ=+$P($G(^DIC(8,+IBZE,0)),U,9) I +IBZ,"6^7"[IBZ S DGNO=1 Q
79 ;
80 I +IBZT,IBZT<8 S DGTYP=$E($P($G(^SD(409.1,+IBZT,0)),U,1),1,3)
81 I +IBZE,DGTYP="" S DGTYP=$E($P($G(^DIC(8,+IBZE,0)),U,1),1,3)
82 Q
83 ;
84SET S DGDT=$P(I,"."),DGDT1=$P(I,".",2)
85 D TYP,ELIG^IBCOPV2 Q:$D(DGNO)!('$D(DGNOD))
86 S:'$D(DGNO) ^UTILITY($J,"OPV",DGDT,DGDT1,DGFIL)=DGTYP_"^"_DGMT_"^"_$S($D(^UTILITY($J,"CPT",0))&(DGFIL=409.5):^UTILITY($J,"CPT",0),1:"")
87 S $P(^UTILITY($J,"OPV",DGDT,DGDT1,DGFIL),"^",6)=$S(DGCOD]"":DGCOD,1:"")
88 S $P(^UTILITY($J,"OPV",DGDT,DGDT1,DGFIL),"^",7)=$G(IBCODCL)
89 S $P(^UTILITY($J,"OPV",DGDT,DGDT1,DGFIL),"^",8)=$G(IBPRV)
90 S $P(^UTILITY($J,"OPV",DGDT,DGDT1,DGFIL),"^",9)=$G(IBOE)
91 Q:'$D(^DGCR(399,"AOPV",DFN,DGDT))
92BIL S DGBIL=0 N IBZ
93 F DGBIL1=1:1 S DGBIL=$O(^DGCR(399,"AOPV",DFN,I,DGBIL)) Q:'DGBIL I $D(^DGCR(399,DGBIL,0)) D
94 . F B=1,7 S DGBIL(B)=$P(^DGCR(399,DGBIL,0),"^",B) I DGBIL(B)]"" D
95 .. I B=7 S IBZ=$P(^DGCR(399,DGBIL,0),"^",27),IBZ=$S(+IBZ=1:"-I",+IBZ=2:"-P",1:"")
96 .. I B=7,$D(^DGCR(399.3,DGBIL(B),0)) S DGBIL(B)=$P(^(0),"^",4) I IBZ'="" S DGBIL(B)=$E(DGBIL(B),1,6)_IBZ
97 .. S $P(^UTILITY($J,"OPV","AP",DGCNT),"^",$S((DGBIL1+B)=2:4,(DGBIL1+B)=8:5,(DGBIL1+B)<8:(DGBIL1+DGBIL1+2),1:(DGBIL1+DGBIL1+3)))=DGBIL(B)
98 Q
99 ;
100CNT F I=0:0 S I=$O(^UTILITY($J,"OPV",I)) Q:'I S DGCNT=DGCNT+1,^UTILITY($J,"OPV","AP",DGCNT)=I D CHG^IBCOPV2,BIL
101 Q
102 ;
103CNT399 S DGCNT1=0 F I=0:0 S I=$O(^DGCR(399,IBIFN,"OP",I)) Q:'I S DGCNT1=DGCNT1+1
104 Q
105 ;
Note: See TracBrowser for help on using the repository browser.