IBTRV31 ;ALB/AAS - CLAIMS TRACKING - REVIEW ACTIONS ; 14-JUL-93
;;Version 2.0 ; INTEGRATED BILLING ;**10**; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
% G EN^IBTRV
;
RDAY(IBTRN) ; -- compute next day for review
N X,IBDAY S IBDAY=1
I $O(^IBT(356.1,"ATRTP",IBTRN,15,0)) S IBDAY=2
I $O(^IBT(356.1,"ATRTP",IBTRN,30,0)) D S IBDAY=-$O(X(""))+1 S:IBDAY<2 IBDAY=2
.S X=0
.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))=""
S:IBDAY<1 IBDAY=1
;
Q IBDAY
;
RDT(IBTRN) ; -- Compute next review date
N IBV,IBTRVDT
S IBV=$O(^IBT(356.1,"ATIDT",IBTRN,"")),IBTRVDT=""
I 'IBV S IBTRVDT=DT
I IBV S:IBV<1 IBV=-IBV S IBTRVDT=$$FMADD^XLFDT(IBV,1)
Q IBTRVDT
;
ASKMORE() ; -- ask if addmore review
N DIR,DIROUT,DUOUT,DTOUT,X,Y
S DIR(0)="Y",DIR("A")="Add Next Review",DIR("B")="YES"
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."
D ^DIR
I $D(DIRUT)!($D(DUOUT))!($D(DTOUT)) S Y="^"
Q $G(Y)
;
ASKSAME() ; -- ask if next review is same as the last
N DIR,DIROUT,DUOUT,DTOUT,X,Y
S DIR(0)="Y",DIR("A")="Is next Review exactly the Same",DIR("B")="YES"
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."
D ^DIR
I $D(DIRUT)!($D(DUOUT))!($D(DTOUT)) S Y="^"
Q $G(Y)
;
COPY(IBTSAV) ; -- Copy a Review
; -- input ibtsav = internal id or review to copy
;
; -- WARNING: This changes the value of IBTRV to the value
; of the new review added
;
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
N I,J,X,Y,DA,DIC,DIE,DR,DIK,IBQUIT,IBTRTP,IBTRN,IBTRVD,IBTRVDT,NODE,IEN,IBNX
S IBQUIT=0
S IBTRVD=$G(^IBT(356.1,IBTSAV,0))
S IBTRVDT=$$FMADD^XLFDT(+IBTRVD,1)
S IBTRN=$P(IBTRVD,"^",2)
S IBTRTP=30 K IBTRV
D PRE^IBTUTL2(IBTRVDT,IBTRN,IBTRTP)
I '$D(IBTRV) G COPYQ
I '$G(IBRDAY) S IBRDAY=$P(IBTRVD,"^",3)+1
;
; -- copy the old review into the new one
;S $P(^IBT(356.1,IBTRV,0),"^",3,24)=$G(IBRDAY)_"^"_$P(IBTRVD,"^",4,23)_"^"_IBTSAV
; replace the above line with following line, 20 piece is set in call to pre^ibtutl2
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
;
S $P(^IBT(356.1,IBTRV,0),"^",22)=$O(^IBE(356.11,"ACODE",30,0))
S $P(^IBT(356.1,IBTRV,1),"^",3,12)=$P(^IBT(356.1,+IBTSAV,1),"^",3,12)
F NODE=12,13 I $D(^IBT(356.1,IBTSAV,NODE,0)) D
.S ^IBT(356.1,IBTRV,NODE,0)=$G(^IBT(356.1,IBTSAV,NODE,0))
.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))
;
S DIK="^IBT(356.1,",DA=IBTRV D IX1^DIK ; index set and kill logic
;
; -- now set next review date to value being copied
S IBNX=$P(IBTRVD,"^",20) ; old value
S:IBNX="" DR=".2///@" S:IBNX DR=".2////"_IBNX
S DA=IBTRV,DIE="^IBT(356.1," D ^DIE
COPYQ Q
;
NXTRVDT(IBTRV) ; -- compute next review date
N X,X1,X2
S X=$P($G(^IBT(356.1,+$G(IBTRV),0)),"^",3)
I $G(X)<1 S X=1
I X>8 S X2=7 ;review every 7 days after 14
I X<9 S X2=3 ;do 3,6,9 day reviews
S X1=DT D C^%DTC
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRV31 3456 printed Nov 22, 2024@17:39:01 Page 2
IBTRV31 ;ALB/AAS - CLAIMS TRACKING - REVIEW ACTIONS ; 14-JUL-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**10**; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
% GOTO EN^IBTRV
+1 ;
RDAY(IBTRN) ; -- compute next day for review
+1 NEW X,IBDAY
SET IBDAY=1
+2 IF $ORDER(^IBT(356.1,"ATRTP",IBTRN,15,0))
SET IBDAY=2
+3 IF $ORDER(^IBT(356.1,"ATRTP",IBTRN,30,0))
Begin DoDot:1
+4 SET X=0
+5 FOR
SET X=$ORDER(^IBT(356.1,"ATRTP",IBTRN,30,X))
if 'X
QUIT
IF $PIECE($GET(^IBT(356.1,X,0)),"^",3)'=""
SET X(-$PIECE(^IBT(356.1,X,0),"^",3))=""
End DoDot:1
SET IBDAY=-$ORDER(X(""))+1
if IBDAY<2
SET IBDAY=2
+6 if IBDAY<1
SET IBDAY=1
+7 ;
+8 QUIT IBDAY
+9 ;
RDT(IBTRN) ; -- Compute next review date
+1 NEW IBV,IBTRVDT
+2 SET IBV=$ORDER(^IBT(356.1,"ATIDT",IBTRN,""))
SET IBTRVDT=""
+3 IF 'IBV
SET IBTRVDT=DT
+4 IF IBV
if IBV<1
SET IBV=-IBV
SET IBTRVDT=$$FMADD^XLFDT(IBV,1)
+5 QUIT IBTRVDT
+6 ;
ASKMORE() ; -- ask if addmore review
+1 NEW DIR,DIROUT,DUOUT,DTOUT,X,Y
+2 SET DIR(0)="Y"
SET DIR("A")="Add Next Review"
SET DIR("B")="YES"
+3 SET DIR("?")="Answer 'Yes' if you want to continue adding the review for the next day or answer 'No' if you are done for now."
+4 DO ^DIR
+5 IF $DATA(DIRUT)!($DATA(DUOUT))!($DATA(DTOUT))
SET Y="^"
+6 QUIT $GET(Y)
+7 ;
ASKSAME() ; -- ask if next review is same as the last
+1 NEW DIR,DIROUT,DUOUT,DTOUT,X,Y
+2 SET DIR(0)="Y"
SET DIR("A")="Is next Review exactly the Same"
SET DIR("B")="YES"
+3 SET 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."
+4 DO ^DIR
+5 IF $DATA(DIRUT)!($DATA(DUOUT))!($DATA(DTOUT))
SET Y="^"
+6 QUIT $GET(Y)
+7 ;
COPY(IBTSAV) ; -- Copy a Review
+1 ; -- input ibtsav = internal id or review to copy
+2 ;
+3 ; -- WARNING: This changes the value of IBTRV to the value
+4 ; of the new review added
+5 ;
+6 ; only stupid programmers get this message
IF '$GET(IBTSAV)!('$GET(^IBT(356.1,+$GET(IBTSAV),0)))
WRITE !!,"DUH, Nothing Added!"
DO PAUSE^VALM1
GOTO COPYQ
+7 NEW I,J,X,Y,DA,DIC,DIE,DR,DIK,IBQUIT,IBTRTP,IBTRN,IBTRVD,IBTRVDT,NODE,IEN,IBNX
+8 SET IBQUIT=0
+9 SET IBTRVD=$GET(^IBT(356.1,IBTSAV,0))
+10 SET IBTRVDT=$$FMADD^XLFDT(+IBTRVD,1)
+11 SET IBTRN=$PIECE(IBTRVD,"^",2)
+12 SET IBTRTP=30
KILL IBTRV
+13 DO PRE^IBTUTL2(IBTRVDT,IBTRN,IBTRTP)
+14 IF '$DATA(IBTRV)
GOTO COPYQ
+15 IF '$GET(IBRDAY)
SET IBRDAY=$PIECE(IBTRVD,"^",3)+1
+16 ;
+17 ; -- copy the old review into the new one
+18 ;S $P(^IBT(356.1,IBTRV,0),"^",3,24)=$G(IBRDAY)_"^"_$P(IBTRVD,"^",4,23)_"^"_IBTSAV
+19 ; replace the above line with following line, 20 piece is set in call to pre^ibtutl2
+20 SET IBNX=$PIECE(^IBT(356.1,IBTRV,0),"^",20)
SET $PIECE(^IBT(356.1,IBTRV,0),"^",3,24)=$GET(IBRDAY)_"^"_$PIECE(IBTRVD,"^",4,23)_"^"_IBTSAV
SET $PIECE(^IBT(356.1,IBTRV,0),"^",20)=IBNX
+21 ;
+22 SET $PIECE(^IBT(356.1,IBTRV,0),"^",22)=$ORDER(^IBE(356.11,"ACODE",30,0))
+23 SET $PIECE(^IBT(356.1,IBTRV,1),"^",3,12)=$PIECE(^IBT(356.1,+IBTSAV,1),"^",3,12)
+24 FOR NODE=12,13
IF $DATA(^IBT(356.1,IBTSAV,NODE,0))
Begin DoDot:1
+25 SET ^IBT(356.1,IBTRV,NODE,0)=$GET(^IBT(356.1,IBTSAV,NODE,0))
+26 SET IEN=0
FOR
SET IEN=$ORDER(^IBT(356.1,IBTSAV,NODE,IEN))
if 'IEN
QUIT
IF $GET(^IBT(356.1,IBTSAV,NODE,IEN,0))'=""
SET ^IBT(356.1,IBTRV,NODE,IEN,0)=$GET(^IBT(356.1,IBTSAV,NODE,IEN,0))
End DoDot:1
+27 ;
+28 ; index set and kill logic
SET DIK="^IBT(356.1,"
SET DA=IBTRV
DO IX1^DIK
+29 ;
+30 ; -- now set next review date to value being copied
+31 ; old value
SET IBNX=$PIECE(IBTRVD,"^",20)
+32 if IBNX=""
SET DR=".2///@"
if IBNX
SET DR=".2////"_IBNX
+33 SET DA=IBTRV
SET DIE="^IBT(356.1,"
DO ^DIE
COPYQ QUIT
+1 ;
NXTRVDT(IBTRV) ; -- compute next review date
+1 NEW X,X1,X2
+2 SET X=$PIECE($GET(^IBT(356.1,+$GET(IBTRV),0)),"^",3)
+3 IF $GET(X)<1
SET X=1
+4 ;review every 7 days after 14
IF X>8
SET X2=7
+5 ;do 3,6,9 day reviews
IF X<9
SET X2=3
+6 SET X1=DT
DO C^%DTC
+7 QUIT X
