Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBTRV31

IBTRV31.m

Go to the documentation of this file. 
  1. IBTRV31	;ALB/AAS - CLAIMS TRACKING -  REVIEW ACTIONS ; 14-JUL-93
  1. 	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
  1. 	;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. 	;
  1. %	G EN^IBTRV
  1. 	;
  1. RDAY(IBTRN)	; -- compute next day for review
  1. 	N X,IBDAY S IBDAY=1
  1. 	I $O(^IBT(356.1,"ATRTP",IBTRN,15,0)) S IBDAY=2
  1. 	I $O(^IBT(356.1,"ATRTP",IBTRN,30,0)) D  S IBDAY=-$O(X(""))+1 S:IBDAY<2 IBDAY=2
  1. 	.S X=0
  1. 	.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))=""
  1. 	S:IBDAY<1 IBDAY=1
  1. 	;
  1. 	Q IBDAY
  1. 	;
  1. RDT(IBTRN)	; -- Compute next review date
  1. 	N IBV,IBTRVDT
  1. 	S IBV=$O(^IBT(356.1,"ATIDT",IBTRN,"")),IBTRVDT=""
  1. 	I 'IBV S IBTRVDT=DT
  1. 	I IBV S:IBV<1 IBV=-IBV S IBTRVDT=$$FMADD^XLFDT(IBV,1)
  1. 	Q IBTRVDT
  1. 	;
  1. ASKMORE()	; -- ask if addmore review
  1. 	N DIR,DIROUT,DUOUT,DTOUT,X,Y
  1. 	S DIR(0)="Y",DIR("A")="Add Next Review",DIR("B")="YES"
  1. 	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."
  1. 	D ^DIR
  1. 	I $D(DIRUT)!($D(DUOUT))!($D(DTOUT)) S Y="^"
  1. 	Q $G(Y)
  1. 	;
  1. ASKSAME()	; -- ask if next review is same as the last
  1. 	N DIR,DIROUT,DUOUT,DTOUT,X,Y
  1. 	S DIR(0)="Y",DIR("A")="Is next Review exactly the Same",DIR("B")="YES"
  1. 	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."
  1. 	D ^DIR
  1. 	I $D(DIRUT)!($D(DUOUT))!($D(DTOUT)) S Y="^"
  1. 	Q $G(Y)
  1. 	;
  1. COPY(IBTSAV)	; -- Copy a Review
  1. 	; -- input ibtsav = internal id or review to copy
  1. 	;
  1. 	; -- WARNING:  This changes the value of IBTRV to the value
  1. 	;              of the new review added
  1. 	;
  1. 	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
  1. 	N I,J,X,Y,DA,DIC,DIE,DR,DIK,IBQUIT,IBTRTP,IBTRN,IBTRVD,IBTRVDT,NODE,IEN
  1. 	S IBQUIT=0
  1. 	S IBTRVD=$G(^IBT(356.1,IBTSAV,0))
  1. 	S IBTRVDT=$$FMADD^XLFDT(+IBTRVD,1)
  1. 	S IBTRN=$P(IBTRVD,"^",2)
  1. 	S IBTRTP=30 K IBTRV
  1. 	D PRE^IBTUTL2(IBTRVDT,IBTRN,IBTRTP)
  1. 	I '$D(IBTRV) G COPYQ
  1. 	I '$G(IBRDAY) S IBRDAY=$P(IBTRVD,"^",3)+1
  1. 	;
  1. 	; -- copy the old review into the new one
  1. 	S $P(^IBT(356.1,IBTRV,0),"^",3,24)=$G(IBRDAY)_"^"_$P(IBTRVD,"^",4,23)_"^"_IBTSAV
  1. 	S $P(^IBT(356.1,IBTRV,0),"^",22)=$O(^IBE(356.11,"ACODE",30,0))
  1. 	S $P(^IBT(356.1,IBTRV,1),"^",3,12)=$P(^IBT(356.1,+IBTSAV,1),"^",3,12)
  1. 	F NODE=12,13 I $D(^IBT(356.1,IBTSAV,NODE,0)) D
  1. 	.S ^IBT(356.1,IBTRV,NODE,0)=$G(^IBT(356.1,IBTSAV,NODE,0))
  1. 	.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))
  1. 	;
  1. 	S DIK="^IBT(356.1,",DA=IBTRV D IX1^DIK ; index set and kill logic
  1. COPYQ	Q
  1. 	;
  1. NXTRVDT(IBTRV)	; -- compute next review date
  1. 	N X,X1,X2
  1. 	S X=$P($G(^IBT(356.1,+$G(IBTRV),0)),"^",3)
  1. 	I $G(X)<1 S X=1
  1. 	I X>8 S X2=7 ;review every 7 days after 14
  1. 	I X<9 S X2=3 ;do 3,6,9 day reviews
  1. 	S X1=DT D C^%DTC
  1. 	Q X