source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC4.m@ 1311

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

initial load of FOIAVistA 6/30/08 version

File size: 4.9 KB
Line 
1IBCSC4 ;ALB/MJB - MCCR SCREEN 4 (INPT. EOC) ;27 MAY 88 10:17
2 ;;2.0;INTEGRATED BILLING;**52,51,210,245,155,287,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;MAP TO DGCRSC4
6 ;
7EN I $P(^DGCR(399,IBIFN,0),"^",5)>2 G EN^IBCSC5
8 I $D(IBASKCOD) K IBASKCOD D CODMUL^IBCU7 I $$BILLCPT^IBCRU4(IBIFN) D ASK^IBCU7A(IBIFN) S DGRVRCAL=1
9 I $D(DGRVRCAL) D ^IBCU6 K DGRVRCAL
10 L ^DGCR(399,IBIFN):1
11 D ^IBCSCU S IBSR=4,IBSR1="",IBV1="0000000"_$S($$FT^IBCEF(IBIFN)'=2:0,1:1),IBUC="UNSPECIFIED CODE"
12 S:IBV IBV1="11111111"
13 D H^IBCSCU F I=1:1:4 S Y="Q"_I_"^IBCVA" D @Y
14 D INP
15 S IBBT=$P(IB(0),"^",4)_$P(IB(0),"^",5)_$P(IB(0),"^",6)
16 D:DGPT(0)]"" DX^IBCSC4A D OCC^IBCVA1
17 I '$P(DGPT(0),U,6) W !?26,$S('DGPT(0):"No PTF record for this ADMISSION",1:"PTF record status: OPEN")
18 S J=$P(IB("U"),U,20),J=$S(J=99:"",J="":"",J=0:"",$L(J)=1:".0"_J,1:"."_J)
19 S Z=1 X IBWW W " Admission : " S I=$S($P(DGPT(0),U,2)]"":$P(DGPT(0),U,2),1:$P(IBIP,U,2)_J) S:$P(I,".",2)=""&I $P(I,".",2)="2400"
20 S Y=$$FMTE^XLFDT(I,"1P")
21 W Y,?49,"Accident Hour: ",$S($P(IB("U"),U,10)=99:IBU,$P(IB("U"),U,10)'="":$P(IB("U"),U,10),1:IBU)
22 W !?4,"Source : " S I=$P(^DD(399,159,0),U,3),I=$P($P(I,";",($P(IB("U"),U,9))),":",2) W I
23 W ?58,"Type: ",$S($P(IB("U"),U,8)=3:"ELECTIVE",$P(IB("U"),U,8)=1:"EMERGENCY",$P(IB("U"),U,8)=2:"URGENT",1:IBU)
24 D OT
25 S Z=2 X IBWW
26 W " Discharge : " S Y=$S($P(IBIP,U,6)>0:$P(IBIP,U,6),1:"") X ^DD("DD") W $S(Y]"":Y,1:IBU)
27 W !?4,"Status : ",$S($P(IB("U"),U,12)]""&($D(^DGCR(399.1,(+$P(IB("U"),"^",12)),0))):$P(^(0),"^",1),1:IBU)
28 N IBPOARR,IBDATE
29 D SET^IBCSC4D(IBIFN,"",.IBPOARR)
30 S IBDATE=$$BDATE^IBACSV(+$G(IBIFN)) ; The EVENT DATE of the bill
31 S Z=3,IBW=1 X IBWW W " Prin. Diag.: " S Y=$$DX(0,IBDATE) W $S(Y'="":$P(Y,U,4)_" - "_$P(Y,U,2),$$DXREQ(IBIFN):IBU,1:IBUN)
32 F I=1:1:4 S Y=$$DX(+Y,IBDATE) Q:Y="" W !?4,"Other Diag.: ",$P(Y,U,4)_" - "_$P(Y,U,2)
33 I +Y S Y=$$DX(+Y,IBDATE) I +Y W !?4,"***There are more diagnoses associated with this bill.***"
34 S Z=4,IBW=1,DGPCM=$P(IB(0),U,9) X IBWW W " Cod. Method: ",$S(DGPCM="":IBUN,DGPCM=9:"ICD-9-CM",DGPCM=4:"CPT-4",1:"HCPCS")
35 D:$D(IBPROC) WRT^IBCSC5
36OCC ;
37 S Z=$S($P(IB(0),U,5)<3:5,1:6)
38 S IBW=1 X IBWW W " Pros. Items: " S Y=$$PD^IBCSC5 I 'Y W IBUN
39 S Z=$S($P(IB(0),U,5)<3:6,1:7) X IBWW
40 W " Occ. Code : " F I=1:1:5 I $D(IBO(I)) W:I>1 !?4,"Occ. Code : ",$E(IBOCN(I),1,27) W:I=1 $E(IBOCN(I),1,27) S Y=IBOCD(I) X ^DD("DD") W ?55,Y S Y=IBOCD2(I) I +Y X ^DD("DD") W " - ",Y
41 I '$D(IBO) W IBUN
42 I $D(IBO)=1,IBO="" W IBUN
43 S Z=$S($P(IB(0),U,5)<3:7,1:8) X IBWW
44 W " Cond. Code : " F I=1:1:5 I $D(IBCC(I)) W:I>1 !?4,"Cond. Code : ",IBCCN(I) W:I=1 IBCCN(I)
45 I '$D(IBCC) W IBUN
46 I $D(IBCC)=1,IBCC="" W IBUN
47 S Z=$S($P(IB(0),U,5)<3:8,1:9)
48 X IBWW W " Value Code : " S IBVC=0
49 I $$FT^IBCEF(IBIFN)'=2 D
50 . D VC^IBCVA1 I +IBVC S J=1,I=0 F S I=$O(IBVC(I)) Q:'I W:J>1 !,?3," Value Code : " W ?17,$E($P(IBVC(I),U,2),1,40),?58,$P(IBVC(I),U,3) S J=J+1
51 W:'IBVC IBUN K IBVC
52 D Q^IBCSC4B G ^IBCSCP
53 Q
54OCC1 W $P(^DGCR(399,IBIFN,"CP",I,0),"^",3)_" - "_$P($$PRCD^IBCEF1($P(^DGCR(399,IBIFN,"CP",I,0),U)),U),?55,"Date: ",Y
55 Q
56 ;IBIP= PTF ptr (399,.08) ^ PTF admiss dt (45,2) or Event dt (399,.03)^ accident hour (399,160)
57 ; ^ source of addmis (399,159) ^ typ of addmiss (399,158)
58 ; ^ PTF disch dt (45,70) or Non-VA disch dt (399,.16) ^ disch status (399,162)
59 ; ^ dxls (45,79) ^ disch bedsection (399,161)
60INP F I="C","U",0 S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"")
61 S IBPTF=$P(IB(0),U,8) F I=0,70 S DGPT(I)=$S(IBPTF="":"",$D(^DGPT(IBPTF,I)):^(I),1:"")
62 F I="C","U",0 S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"")
63 S IBIP=IBPTF_"^"_$S($P(DGPT(0),"^",2)]"":$P(DGPT(0),"^",2),1:$P(IB(0),"^",3))_"^"_$P(IB("U"),"^",10)_"^"_$P(IB("U"),"^",9)_"^"_$P(IB("U"),"^",8)_"^"_$S(+DGPT(70)>0:+DGPT(70),1:$P(IB(0),"^",16))_"^"
64 S IBIP=IBIP_$P(IB("U"),"^",12)_"^"_$S($D(DGPT(70)):$P(DGPT(70),"^",10),1:"")_"^"_$P(IB("U"),"^",11)
65 Q
66SET ;S ^DD(399.0304,0,"ID","WRITE")="N X S X=^(0) W "" "",$E($P($G(@(U_$P($P(X,U),"";"",2)_+X_"",0)"")),U,$S($P(X,U,1)[""CPT"":2,1:4)),1,30)"
67 Q
68 ;
69DX(ORDER,IBDATE) ; Get next diagnosis data
70 N IBX
71 S IBX=""
72 S ORDER=$O(IBPOARR(ORDER))
73 I ORDER S IBX=ORDER_U_$$ICD9^IBACSV(+IBPOARR(ORDER),$G(IBDATE))
74 Q IBX
75 ;
76OT ; print Other Care (SNF) multiple
77 N IBX,IBY,IBN I '$O(^DGCR(399,IBIFN,"OT",0)) W !,?4,"SNF Care : UNSPECIFIED [NOT REQUIRED]"
78 S IBX=0 F S IBX=$O(^DGCR(399,IBIFN,"OT",IBX)) Q:'IBX D
79 . S IBY=$G(^DGCR(399,IBIFN,"OT",IBX,0)) Q:'IBY
80 . S IBN=$P($G(^DGCR(399.1,+IBY,0)),U,1),IBN=$S(IBN["SKILLED":"SNF Care ",IBN["SUB-ACUTE":"Sub-Acute",1:"Unknown ")
81 . W !,?4,IBN," : ",$$FMTE^XLFDT(+$P(IBY,U,2))," - ",$$FMTE^XLFDT(+$P(IBY,U,3))
82 Q
83 ;
84DXREQ(IBIFN) ; Is the principle diagnosis code required or not?
85 ; Function returns true (1) if DX is required for this bill, otherwise 0
86 NEW REQ,IBFT
87 S REQ=0,IBFT=$$FT^IBCEF(IBIFN)
88 I IBFT=2 S REQ=1 G DXREQX ; required for CMS-1500
89 I IBFT=3,$$WNRBILL^IBEFUNC(IBIFN) S REQ=1 G DXREQX ; UB with Medicare (WNR) current payer
90DXREQX ;
91 Q REQ
92 ;
93 ;IBCSC4
Note: See TracBrowser for help on using the repository browser.