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

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

initial load of WorldVistAEHR
File size: 4.5 KB
Line 
1IBTRV2 ;ALB/AAS - CLAIMS TRACKING - REVIEW ACTIONS ;19-JUL-93
2 ;;2.0;INTEGRATED BILLING ;**60,210,266**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5% G EN^IBTRV
6 ;
7DA(IBTRN) ; -- Add Diagnosis
8 ; -- bld = non-zero means not from main tracking entry.
9 ;
10 N IBETYP
11 D FULL^VALM1
12 I IBETYP=2 D
13 .I $P(IBTRND,"^",4) D ASK^IBTUTL4(IBTRN,2)
14 .I '$P(IBTRND,"^",4) W !!,"Can not add diagnosis to outpatient visits prior to Check-out.",! D PAUSE^VALM1
15 I IBETYP=1 D EN^IBTRE3(IBTRN)
16 I '$G(BLD) D DRG,BLD^IBTRV
17 S VALMBCK="R"
18 Q
19 ;
20PROC(IBTRN,IBETYP,BLD) ; -- Add Procedures
21 ; -- bld = non-zero means not from main tracking entry.
22 ;
23 I '$G(BLD) D FULL^VALM1
24 I IBETYP=2 W !!,"Outpatient Procedures should be entered using Add/Edit action in",!,"Appointment Management.",! D PAUSE^VALM1
25 I IBETYP=1 D EN^IBTRE4(IBTRN)
26 I '$G(BLD) D BLD^IBTRV
27 S VALMBCK="R"
28 Q
29PROV(IBTRN,IBETYP,BLD) ; -- Add Procedures
30 ; -- bld = non-zero means not from main tracking entry.
31 ;
32 I '$G(BLD) D FULL^VALM1
33 I IBETYP=1 D EN^IBTRE5(IBTRN)
34 I IBETYP=2,$P(IBTRND,"^",4) D ASK^IBTUTL4(IBTRN,1)
35 I IBETYP=3 W !!,"Provider information for Prescriptions comes from the pharmacy package silly.",! D PAUSE^VALM1
36 I IBETYP=4 W !!,"Provider information for Prosthetics comes from the prothetics package silly.",! D PAUSE^VALM1
37 I '$G(BLD) D BLD^IBTRV
38 S VALMBCK="R"
39 Q
40 ;
41DRG(IBTRN) ; -- entry point to compute drg
42 ; generally called from ad or pr above caller does own rebuild
43 N DIR,DA,DR,DIC,DIE,IBALOS,IBDRG,IBTRVD,DGPMCA,DX
44 S DGPMCA=$P(^IBT(356,IBTRN,0),"^",5) Q:'DGPMCA
45 ;
46 ; -- can't compute drg if no primary(dxls) diagnosis
47 S DX=$O(^IBT(356.9,"ATP",DGPMCA,1,0)) Q:'DX
48 D DISPDRG(DGPMCA)
49 ;
50 S DIR("?")="Answer 'Yes' to compute and store a new interim drg, answer 'No' to quit."
51 S DIR("A")="Ready to compute New Interim DRG",DIR("B")="NO",DIR(0)="Y" D ^DIR K DIR
52 I Y=1 D
53 .S IBDRG=$$COMDRG(IBTRN) Q:+IBDRG<1
54 .W !!,"DRG computes to: ",IBDRG," - ",$$DRGTD^IBACSV(IBDRG,$$TRNDATE^IBACSV(IBTRN))
55 .;
56 .S IBDA=$O(^IBT(356.93,"AMVD",DGPMCA,DT,0))
57 .I +IBDA<1 D
58 ..K DD,DO
59 ..S X=IBDRG
60 ..S DIC="^IBT(356.93,",DIC(0)="L",DLAYGO=356.93
61 ..S DIC("DR")=".02////"_DGPMCA_";.03////"_DT
62 ..D FILE^DICN K DIC S IBDA=+Y
63 .I +IBDA<1 Q
64 .;
65 .L +^IBT(356.93,IBDA):5 I '$T D LOCKED^IBTRCD1 Q
66 .S DIE="^IBT(356.93,",DA=IBDA
67 .S DR=".01////^S X=IBDRG;.01;S IBALOS=$$ALOS^IBTRV2(IBDRG,DT);.04//^S X=IBALOS;.05//^S X=$$DAYREM^IBTRV2(DGPMCA,IBALOS)"
68 .D ^DIE W !
69 .L -^IBT(356.93,+IBDA)
70 Q
71 ;
72DAYREM(DGPM,LOS) ; -- Compute days remaining
73 N IBX,DIFF S IBX=LOS
74 S DIFF=$$FMDIFF^XLFDT(DT,+$G(^DGPM(DGPM,0))) S:DIFF<0 DIFF=-DIFF
75 S IBX=LOS-DIFF
76 I IBX<0 S IBX=0
77 Q IBX\1
78 ;
79ALOS(X,Y) ; -- compute alos for drg for year
80 ; input x = pointer to drg file
81 ; y = date
82 N IBDT,J
83 S IBDT=0 F S IBDT=$O(^IBE(356.5,"ADR",X,IBDT)) Q:'IBDT!(IBDT>Y) D
84 .S J=$O(^IBE(356.5,"ADR",X,IBDT,0))
85 Q $P($G(^IBE(356.5,+$G(J),0)),"^",3)
86 ;
87COMDRG(IBTRN) ; -- compute drg from tracking file
88 ;*********************************************************
89 ; -- needed variable
90 ; SEX = m or f
91 ; AGE = whole number 0-120
92 ; ICDEXP = patient died during this episode
93 ; ICDTRS = patient transfered to acute care facility
94 ; ICDDMS = patient had irregular discharge
95 ; ICDDX( = diagnosis codes
96 ; ICDPRC( = procedure codes
97 ;*********************************************************
98 N SEX,ICDEXP,ICDTRS,ICDDMS,ICDDX,ICDPRC,DX,PR,I,J,IBCNT,ICDMDC,ICDDRG,ICDDATE
99 S ICDDRG="",(ICDEXP,ICDTRS,ICDDMS,IBCNT)=0,DFN=$P(^IBT(356,IBTRN,0),"^",2)
100 ;
101 S SEX=$P($G(^DPT(DFN,0)),U,2)
102 S AGE=$$FMDIFF^XLFDT(DT,$P($G(^DPT(DFN,0)),U,3))\365.25
103 S DGPMA=$P(^IBT(356,IBTRN,0),"^",5) G:'DGPMA COMDRGQ
104 ;
105 S IBCNT=1,DX=0
106 S ICDDX(1)=+$G(^IBT(356.9,+$O(^IBT(356.9,"ATP",DGPMA,+$O(^IBT(356.9,"ATP",DGPMA,0)),0)),0))
107 F S DX=$O(^IBT(356.9,"C",DGPMA,DX)) Q:'DX S X=$G(^IBT(356.9,DX,0)) I $P(X,"^",4)=2 S IBCNT=IBCNT+1,ICDDX(IBCNT)=+X
108 ;
109 S IBCNT=0,J=""
110 F S J=$O(^IBT(356.91,"APP",DGPMA,J)) Q:'J S PR="" F S PR=$O(^IBT(356.91,"APP",DGPMA,J,PR)) Q:'PR S IBCNT=IBCNT+1,ICDPRC(IBCNT)=+$G(^IBT(356.91,PR,0))
111 ;
112 I $D(ICDDX(1)) S ICDDATE=$$TRNDATE^IBACSV(IBTRN) D ^ICDDRG
113COMDRGQ Q ICDDRG
114 ;
115DISPDRG(DGPMCA) ; -- Display drg's
116 N I,J,IBDRG
117 W !!,"Current Interim DRGs on File:"
118 S I=0,IBCNT=0 F S I=$O(^IBT(356.93,"AMVD",DGPMCA,I)) Q:'I S J=0 F S J=$O(^IBT(356.93,"AMVD",DGPMCA,I,J)) Q:'J D
119 .S IBDRG=$G(^IBT(356.93,J,0))
120 .W !?5,$$DAT1^IBOUTL($P(IBDRG,"^",3)),?16,+IBDRG," - ",$$DRGTD^IBACSV(+IBDRG,$P(IBDRG,"^",3))
121 .S IBCNT=IBCNT+1
122 I IBCNT<1 W !?5,"None on file."
123 W !
124 Q
Note: See TracBrowser for help on using the repository browser.