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

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

initial load of FOIAVistA 6/30/08 version

File size: 5.1 KB
Line 
1IBTRE4 ;ALB/AAS - CLAIMS TRACKING EDIT PROCEDURE ;1-SEP-93
2 ;;2.0;INTEGRATED BILLING;**10,210,266**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5% G ^IBTRE
6 ;
7EN(IBTRN) ; -- entry point for protocols
8 ; must do own rebuild actions
9 ; -- Input - point to 356
10 ;
11 N IBETYP,IBTRND,IBXY,IBCNT,IBDGPM
12 D FULL^VALM1
13 S VALMBCK=""
14 S IBTRND=$G(^IBT(356,IBTRN,0)),IBDGPM=$P(IBTRND,"^",5)
15 ;
16 S IBETYP=$$TRTP^IBTRE1(IBTRN)
17 I IBETYP>2 W !!,"Clinical Information comes from the parent package." D PAUSE^VALM1 G ENQ
18 ;
19 ; -- outpatient procedure
20 I IBETYP=2 D G ENQ
21 .W !!,*7,"You must use the add/edit action on Check-out to add procedures to Outpatient Encounters.",!
22 .S VALMBCK="R"
23 ;
24 ; -- Inpatient procedure
25 Q:'IBDGPM
26 I IBETYP=1 D PROC(IBTRN,IBETYP) S VALMBCK="R"
27 ;
28ENQ ;
29 Q
30 ;
31PROC(IBTRN,IBETYP) ; -- add/edit procedure
32 Q:'IBTRN
33 I $G(IBETYP)'=1 Q
34 N DA,DR,DIC,DIE
35 ;S IBDGPM=$P(^IBT(356,+IBTRN,0),"^",5)
36 I IBETYP'=1!('IBDGPM) W !!,"You can only enter a procedure for an admission",! D PAUSE^VALM1 G PROCQ
37 ;
38 S X="IOINHI;IOINORM" D ENDR^%ZISS
39 W !!,"--- ",IOINHI,"Procedure",IOINORM," --- "
40 S IBSEL="Add"
41 D SET(IBTRN) I $D(IBXY) D LIST(.IBXY) S IBSEL=$$ASK(IBCNT,"A")
42 I IBSEL["^"!(IBSEL["Return") S:IBSEL["^" IBQUIT=1 G PROCQ
43 I IBSEL="Add" D ADD(IBTRN)
44 I IBSEL D EDT(+$G(IBXY(+IBSEL)),".01;.03;"),CHECK(+$G(IBXY(+IBSEL)))
45PROCQ Q
46 ;
47CHECK(IBADG) ; Check active status of the ICD0 code (Code Set Versioning)
48 N IBZ,DIR,X,Y
49 S IBZ=$G(^IBT(356.91,+$G(IBADG),0)) Q:'IBZ
50 Q:$$ICD0ACT^IBACSV(+IBZ,$P(IBZ,U,3))
51 W !!,*7,"Warning! The Procedure Code ",$P($$ICD0^IBACSV(+IBZ),U)," is inactive on this date!"
52 S DIR(0)="EA",DIR("A")="Press <Enter> to continue" D ^DIR
53 Q
54 ;
55ADD(IBTRN,TYPE) ; -- Add a new procedure
56 ;
57 N DTOUT,DUTOU,X,Y,DIC,DIR,IBDATE,IBP,IBPN,IBPDT,IBADT,ICDVDT
58 ;Service date (for CSV)
59 S IBDATE=$$TRNDATE^IBACSV(IBTRN)
60 S IBADT=$G(^DGPM(+$$DGPM^IBTRE3(IBTRN),0)) ;Admission Date
61 S IBCNT=0
62 I '$G(TYPE) S TYPE=""
63NXT ; The Procedure Date has to be asked first for the Code Set Versioning requirements
64 ; Input Procedure Date
65 S DIR(0)="D",DIR("A")=$S(IBCNT<1:"Procedure Date",1:"Next Procedure Date")
66 S DIR("B")=$$DAT3^IBOUTL(IBDATE)
67 W:$G(IBCNT) !
68 S IBPDT=IBDATE D ^DIR K DIR G ADDQ:Y'?7N S IBPDT=+Y W " ",$$DAT2^IBOUTL(IBPDT)
69 ; The same checking as in the Data Dictionary, file #356.91, field #.03 (PROCEDURE DATE):
70 I IBADT,(IBPDT+.9)<IBADT W !!,*7,"The Procedure Date cannot be earlier than Admission (",$$DAT3^IBOUTL(IBADT),")",! G NXT
71 ; Input Procedure (ICD0)
72 S DIC("A")="Select Procedure: "
73 S DIC("S")="I $$ICD0ACT^IBACSV(+Y,IBPDT)"
74 S ICDVDT=IBPDT ; for DD ID (versioned text)
75 S DIC="^ICD0(",DIC(0)="AEMQ",X=""
76 D ^DIC K DIC G ADDQ:Y'>0
77 S IBP=+Y,IBPN=$P(Y,U,2) ; Procedure IEN and name
78 ;I '$$ICD0ACT^IBACSV(IBP,IBPDT) W !!,*7,IBPN," is not active for the procedure date ("_$$DAT3^IBOUTL(IBPDT),").",! G NXT
79 I $D(^IBT(356.91,"ADGPM",$$DGPM^IBTRE3(IBTRN),IBP)) W !!,*7,IBPN," is already a procedure.",!
80 S IBCNT=IBCNT+1
81 S IBADG=$$NEW(IBP,IBTRN,TYPE,IBPDT)
82 I IBADG>0,TYPE'=3 G NXT ;D EDT(IBADG) G NXT
83ADDQ Q
84 ;
85NEW(ICDI,IBTRN,TYPE,IBPDT) ; -- file new entry
86 ;
87 N DA,DD,DO,DIC,DIK,DINUM,DLAYGO,X,Y,I,J
88 S X=ICDI,(DIC,DIK)="^IBT(356.91,",DIC(0)="L",DLAYGO=356.91
89 D FILE^DICN S IBADG=+Y I Y'>0 G NEWQ
90 I '$G(IBPDT) S IBPDT=$P($P(^IBT(356,IBTRN,0),"^",6),".")
91 L +^IBT(356.91,IBADG) S $P(^IBT(356.91,IBADG,0),"^",2,3)=$$DGPM^IBTRE3(IBTRN)_"^"_IBPDT,DA=IBADG D IX1^DIK L -^IBT(356.91,IBADG)
92NEWQ Q IBADG
93 ;
94EDT(IBADG,IBDR) ; -- edit entry
95 ;
96 N DR,DIE,DA,DIDEL
97 S DR=$G(IBDR),DIDEL=356.91 I DR="" S DR=".03;"
98 S DA=IBADG,DIE="^IBT(356.91,"
99 Q:'$G(^IBT(356.91,DA,0))
100 L +^IBT(356.91,IBADG):5 I '$T D LOCKED^IBTRCD1 G EDTQ
101 D ^DIE
102 L -^IBT(356.91,IBADG)
103EDTQ Q
104 ;
105SET(IBTRN) ; -- set array
106 N IBDGPM,IBICD
107 S IBDGPM=$$DGPM^IBTRE3(IBTRN)
108 S (IBICD,IBDA,IBCNT)=0
109 F S IBICD=$O(^IBT(356.91,"ADGPM",IBDGPM,IBICD)) Q:'IBICD S IBDA=0 F S IBDA=$O(^IBT(356.91,"ADGPM",IBDGPM,IBICD,IBDA)) Q:'IBDA D
110 .Q:'$D(^IBT(356.91,+IBDA,0))
111 .S IBCNT=IBCNT+1
112 .S IBXY(IBCNT)=IBDA_"^"_IBICD
113SETQ Q
114 ;
115LIST(IBXY) ;List Diagnosis Array
116 ; Input -- IBXY Diagnosis Array Subscripted by a Number
117 ; Output -- List Diagnosis Array
118 N I,IBXD,IBDATE
119 W !
120 S I=0 F S I=$O(IBXY(I)) Q:'I D
121 . S IBTNOD=$G(^IBT(356.91,+IBXY(I),0))
122 . S IBDATE=$P($P(IBTNOD,U,3),".") ; Procedure date
123 . S IBXD=$$ICD0^IBACSV(+$P(IBXY(I),U,2),IBDATE)
124 . W !?2,I," ",$P(IBXD,U),?15,$E($P(IBXD,U,4),1,43),?60,$$DAT1^IBOUTL(IBDATE)
125 Q
126 ;
127ASK(IBCNT,IBPAR,IBSELDF) ;Ask user to select from list
128 ; Input -- SDCNT Number of Entities
129 ; SDPAR Selection Parameters (A=Add)
130 ; SDSELDF Selection Default [Optional]
131 ; Output -- Selection
132 N DIR,DIRUT,DTOUT,DUOUT,X,Y
133REASK S DIR("?")="Enter "_$S($G(IBSELDF)]"":"<RETURN> for '"_IBSELDF_"', ",1:"")_$S(IBCNT=1:"1",1:"1-"_IBCNT)_" to Edit"_$S(IBPAR["A":", or 'A' to Add",1:"")
134 S DIR("A")="Enter "_$S(IBCNT=1:"1",1:"1-"_IBCNT)_" to Edit"_$S(IBPAR["A":", or 'A' to Add",1:"")_": "_$S($G(IBSELDF)]"":IBSELDF_"// ",1:"")
135 S DIR(0)="FAO^1:30"
136 D ^DIR I $D(DTOUT)!($D(DUOUT)) S Y="^" G ASKQ
137 S Y=$$UPPER^VALM1(Y)
138 I Y?.N,Y,Y'>IBCNT G ASKQ
139 I IBPAR["A",$E(Y)="A" S Y="Add" G ASKQ
140 I Y="" S Y=$S($G(IBSELDF)]"":IBSELDF,1:"Return") G ASKQ
141 W !!?5,DIR("?"),".",! G REASK
142ASKQ Q $G(Y)
Note: See TracBrowser for help on using the repository browser.