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

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

initial load of WorldVistAEHR

File size: 3.3 KB
Line 
1IBTRV31 ;ALB/AAS - CLAIMS TRACKING - REVIEW ACTIONS ; 14-JUL-93
2 ;;Version 2.0 ; INTEGRATED BILLING ;**10**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5% G EN^IBTRV
6 ;
7RDAY(IBTRN) ; -- compute next day for review
8 N X,IBDAY S IBDAY=1
9 I $O(^IBT(356.1,"ATRTP",IBTRN,15,0)) S IBDAY=2
10 I $O(^IBT(356.1,"ATRTP",IBTRN,30,0)) D S IBDAY=-$O(X(""))+1 S:IBDAY<2 IBDAY=2
11 .S X=0
12 .F S X=$O(^IBT(356.1,"ATRTP",IBTRN,30,X)) Q:'X I $P($G(^IBT(356.1,X,0)),"^",3)'="" S X(-$P(^IBT(356.1,X,0),"^",3))=""
13 S:IBDAY<1 IBDAY=1
14 ;
15 Q IBDAY
16 ;
17RDT(IBTRN) ; -- Compute next review date
18 N IBV,IBTRVDT
19 S IBV=$O(^IBT(356.1,"ATIDT",IBTRN,"")),IBTRVDT=""
20 I 'IBV S IBTRVDT=DT
21 I IBV S:IBV<1 IBV=-IBV S IBTRVDT=$$FMADD^XLFDT(IBV,1)
22 Q IBTRVDT
23 ;
24ASKMORE() ; -- ask if addmore review
25 N DIR,DIROUT,DUOUT,DTOUT,X,Y
26 S DIR(0)="Y",DIR("A")="Add Next Review",DIR("B")="YES"
27 S DIR("?")="Answer 'Yes' if you want to continue adding the review for the next day or answer 'No' if you are done for now."
28 D ^DIR
29 I $D(DIRUT)!($D(DUOUT))!($D(DTOUT)) S Y="^"
30 Q $G(Y)
31 ;
32ASKSAME() ; -- ask if next review is same as the last
33 N DIR,DIROUT,DUOUT,DTOUT,X,Y
34 S DIR(0)="Y",DIR("A")="Is next Review exactly the Same",DIR("B")="YES"
35 S DIR("?")="Answer 'Yes' if you want the next review to be exactly the same (I'll update the day for review automatically) or answer 'No' if you wish to edit the review now."
36 D ^DIR
37 I $D(DIRUT)!($D(DUOUT))!($D(DTOUT)) S Y="^"
38 Q $G(Y)
39 ;
40COPY(IBTSAV) ; -- Copy a Review
41 ; -- input ibtsav = internal id or review to copy
42 ;
43 ; -- WARNING: This changes the value of IBTRV to the value
44 ; of the new review added
45 ;
46 I '$G(IBTSAV)!('$G(^IBT(356.1,+$G(IBTSAV),0))) W !!,"DUH, Nothing Added!" D PAUSE^VALM1 G COPYQ ; only stupid programmers get this message
47 N I,J,X,Y,DA,DIC,DIE,DR,DIK,IBQUIT,IBTRTP,IBTRN,IBTRVD,IBTRVDT,NODE,IEN,IBNX
48 S IBQUIT=0
49 S IBTRVD=$G(^IBT(356.1,IBTSAV,0))
50 S IBTRVDT=$$FMADD^XLFDT(+IBTRVD,1)
51 S IBTRN=$P(IBTRVD,"^",2)
52 S IBTRTP=30 K IBTRV
53 D PRE^IBTUTL2(IBTRVDT,IBTRN,IBTRTP)
54 I '$D(IBTRV) G COPYQ
55 I '$G(IBRDAY) S IBRDAY=$P(IBTRVD,"^",3)+1
56 ;
57 ; -- copy the old review into the new one
58 ;S $P(^IBT(356.1,IBTRV,0),"^",3,24)=$G(IBRDAY)_"^"_$P(IBTRVD,"^",4,23)_"^"_IBTSAV
59 ; replace the above line with following line, 20 piece is set in call to pre^ibtutl2
60 S IBNX=$P(^IBT(356.1,IBTRV,0),"^",20),$P(^IBT(356.1,IBTRV,0),"^",3,24)=$G(IBRDAY)_"^"_$P(IBTRVD,"^",4,23)_"^"_IBTSAV,$P(^IBT(356.1,IBTRV,0),"^",20)=IBNX
61 ;
62 S $P(^IBT(356.1,IBTRV,0),"^",22)=$O(^IBE(356.11,"ACODE",30,0))
63 S $P(^IBT(356.1,IBTRV,1),"^",3,12)=$P(^IBT(356.1,+IBTSAV,1),"^",3,12)
64 F NODE=12,13 I $D(^IBT(356.1,IBTSAV,NODE,0)) D
65 .S ^IBT(356.1,IBTRV,NODE,0)=$G(^IBT(356.1,IBTSAV,NODE,0))
66 .S IEN=0 F S IEN=$O(^IBT(356.1,IBTSAV,NODE,IEN)) Q:'IEN I $G(^IBT(356.1,IBTSAV,NODE,IEN,0))'="" S ^IBT(356.1,IBTRV,NODE,IEN,0)=$G(^IBT(356.1,IBTSAV,NODE,IEN,0))
67 ;
68 S DIK="^IBT(356.1,",DA=IBTRV D IX1^DIK ; index set and kill logic
69 ;
70 ; -- now set next review date to value being copied
71 S IBNX=$P(IBTRVD,"^",20) ; old value
72 S:IBNX="" DR=".2///@" S:IBNX DR=".2////"_IBNX
73 S DA=IBTRV,DIE="^IBT(356.1," D ^DIE
74COPYQ Q
75 ;
76NXTRVDT(IBTRV) ; -- compute next review date
77 N X,X1,X2
78 S X=$P($G(^IBT(356.1,+$G(IBTRV),0)),"^",3)
79 I $G(X)<1 S X=1
80 I X>8 S X2=7 ;review every 7 days after 14
81 I X<9 S X2=3 ;do 3,6,9 day reviews
82 S X1=DT D C^%DTC
83 Q X
Note: See TracBrowser for help on using the repository browser.