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

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

initial load of FOIAVistA 6/30/08 version

File size: 4.5 KB
Line 
1IBTRE5 ;ALB/AAS - CLAIMS TRACKING EDIT PROVIDER ; 1-SEP-93
2 ;;Version 2.0 ; INTEGRATED BILLING ;**10,60**; 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 - pointer 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 provider
20 I IBETYP=2 D G ENQ
21 .I $P(IBTRND,"^",4) D ASK^IBTUTL4(IBTRN,1)
22 .I '$P(IBTRND,"^",4) W !!,"Can not add provider to outpatient visits prior to Check-out.",! D PAUSE^VALM1
23 .S VALMBCK="R"
24 ;
25 ; -- Inpatient provider
26 I IBETYP=1 D
27 .Q:'IBDGPM
28 .; -- ask admitting provider
29 .I '$O(^IBT(356.94,"ADG",IBDGPM,0)) D APRVD(IBTRN,IBETYP)
30 .I $G(IBSEL)="^" Q
31 .;
32 .; -- edit other provider
33 .D PRVD(IBTRN,IBETYP)
34 .S VALMBCK="R"
35 ;
36ENQ ;
37 Q
38APRVD(IBTRN,IBETYP) ; -- add admitting provider
39 ;
40 N IBAPR,DA,DR,DIC,DIE,DD,DO,IOINHI,IOINORM
41 S IBAPR=""
42 ;
43 I IBETYP'=1!('IBDGPM) W !!,"You can only enter and admitting provider for an admission",! D PAUSE^VALM1 G APRVDQ
44 ;
45 S X="IOINHI;IOINORM" D ENDR^%ZISS
46 S IBAPR=$O(^IBT(356.94,"ADG",IBDGPM,0)) I IBAPR S IBDA=$O(^IBT(356.94,"ADG",IBDGPM,IBAPR,0))
47 W !!,"--- ",IOINHI,"Admitting Physician",IOINORM," --- ",$S('IBAPR:"Unspecified",1:$P($G(^VA(200,+$P(IBAPR,"^",3),0)),"^"))
48 I +IBAPR D EDT(IBDA,".03;") W !
49 I '$O(^IBT(356.94,"ADG",IBDGPM,0)) D ADD(IBTRN,3)
50 ;
51 W !
52APRVDQ Q
53 ;
54PRVD(IBTRN,IBETYP) ; -- add/edit provider
55 Q:'IBTRN
56 I $G(IBETYP)'=1 Q
57 N DA,DR,DIC,DIE
58 I IBETYP'=1!('IBDGPM) W !!,"You can only enter a provider for an admission",! D PAUSE^VALM1 G PRVDQ
59 ;
60 S X="IOINHI;IOINORM" D ENDR^%ZISS
61 W !!,"--- ",IOINHI,"Provider",IOINORM," --- "
62 S IBSEL="Add"
63 D SET(IBTRN) I $D(IBXY) D LIST(.IBXY) S IBSEL=$$ASK^IBTRE4(IBCNT,"A")
64 I IBSEL["^"!(IBSEL["Return") S:IBSEL["^" IBQUIT=1 G PRVDQ
65 I IBSEL="Add" D ADD(IBTRN)
66 D:IBSEL EDT(+$G(IBXY(+IBSEL)),".01;.03;.04")
67PRVDQ Q
68 ;
69ADD(IBTRN,TYPE) ; -- Add a new provider
70 ;
71 N DTOUT,DUTOU,X,Y,DIC
72 S IBCNT=0
73 I '$G(TYPE) S TYPE=""
74NXT S DIC("A")=$S(TYPE=3:"Admitting Provider: ",IBCNT<1:"Select Provider: ",1:"Next Provider: ")
75 S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U,1),+Y))"
76 S DIC="^VA(200,",DIC(0)="AEMQ",X=""
77 W:$G(IBCNT) ! D ^DIC K DIC G ADDQ:Y<0
78 S IBCNT=IBCNT+1
79 S IBAPR=$$NEW(+Y,IBTRN,TYPE)
80 I IBAPR,TYPE'=3 D EDT(IBAPR) G NXT
81ADDQ I $D(DUOUT)!($D(DTOUT)) S IBSEL="^"
82 Q
83 ;
84NEW(VA200,IBTRN,TYPE) ; -- file new entry
85 ;
86 N DA,DD,DO,DIC,DIK,DINUM,DLAYGO,X,Y,I,J
87 ;
88 ; -- default date = episode date
89 S X=$P($P(^IBT(356,IBTRN,0),"^",6),".")
90 S (DIC,DIK)="^IBT(356.94,",DIC(0)="L",DLAYGO=356.94
91 D FILE^DICN S IBAPR=+Y
92 I IBAPR>0 L +^IBT(356.94,IBAPR) S $P(^IBT(356.94,IBAPR,0),"^",2,4)=$$DGPM^IBTRE3(IBTRN)_"^"_VA200_"^"_$G(TYPE),DA=IBAPR D IX1^DIK L -^IBT(356.94,IBAPR)
93NEWQ Q IBAPR
94 ;
95EDT(IBAPR,IBDR) ; -- edit entry
96 ;
97 N DR,DIE,DA,DIDEL
98 S DR=$G(IBDR),DIDEL=356.94 I DR="" S DR=".01;.03;.04"
99 S DA=IBAPR,DIE="^IBT(356.94,"
100 Q:'$G(^IBT(356.94,DA,0))
101 L +^IBT(356.94,IBAPR):5 I '$T D LOCKED^IBTRCD1 G EDTQ
102 D ^DIE
103 L -^IBT(356.94,IBAPR)
104EDTQ Q
105 ;
106SET(IBTRN) ; -- set array
107 N IBDGPM,IBPRV
108 S IBDGPM=$$DGPM^IBTRE3(IBTRN)
109 S (IBPRV,IBCNT)=0
110 F S IBPRV=$O(^IBT(356.94,"ADGPM",IBDGPM,IBPRV)) Q:'IBPRV S IBDA=0 F S IBDA=$O(^IBT(356.94,"ADGPM",IBDGPM,IBPRV,IBDA)) Q:'IBDA D
111 .Q:'$D(^IBT(356.94,+IBDA,0))
112 .S IBCNT=IBCNT+1
113 .S IBXY(IBCNT)=IBDA
114SETQ Q
115 ;
116LIST(IBXY) ;List Provider Array
117 ; Input -- IBXY Provider Array Subscripted by a Number
118 ; Output -- List Provider Array
119 N I,IBXD,IBTNOD
120 W !
121 S I=0 F S I=$O(IBXY(I)) Q:'I D
122 .S IBTNOD=$G(^IBT(356.94,+IBXY(I),0))
123 .S IBXD=$P($G(^VA(200,$P(IBTNOD,"^",3),0)),"^")
124 .W !?2,I," ",IBXD,?40,$$DAT1^IBOUTL($P($P(IBTNOD,"^",1),"."),2),?60,$$EXPAND^IBTRE(356.94,.04,$P(IBTNOD,"^",4))
125 Q
126 ;
127DICS(Y) ; -- called by input transform and screen logic for type of provider
128 N IBY
129 S IBY=0
130 I Y<3 S IBY=1 G DICSQ
131 I Y=3 I '$D(^IBT(356.94,"ATP",+$P($G(^IBT(356.94,DA,0)),U,2),3))!($O(^IBT(356.94,"ATP",+$P($G(^IBT(356.94,DA,0)),U,2),3,0))=DA) S IBY=1
132DICSQ Q IBY
133 ;
134DTCHK(DA,X) ; -- input transform for 356.94;.01. date not before admission or after discharge
135 N IBTRN,IBOK,IBCDT
136 S IBOK=1
137 G:'DA!($G(X)<1) DTCHKQ
138 S IBTRN=+$O(^IBT(356,"AD",+$P(^IBT(356.94,DA,0),"^",2),0))
139 G:'IBTRN DTCHKQ
140 S IBCDT=$$CDT^IBTODD1(IBTRN)
141 I X<$P(+IBCDT,".") S IBOK=0 G DTCHKQ ;before adm
142 I $P(IBCDT,"^",2),X>$P(IBCDT,"^",2) S IBOK=0 G DTCHKQ ; after disch
143 I X>$$FMADD^XLFDT(DT,7) S IBOK=0 G DTCHKQ
144 ;
145DTCHKQ Q IBOK
Note: See TracBrowser for help on using the repository browser.