ADERVURD ;IHS/ITSC/TPF - READ NEW RVUS FROM FILE AND PLACE INTO ADA CODE FILE 8/27/2003 12:50:16 PM
;;6.0;ADE;**15**;JAN 01, 2004
S U="^"
ASK W @IOF
K DIR
S DIR("B")=$G(^XTV(8989.3,1,"DEV"))
S DIR(0)="FO",DIR("A")="Enter the directory path for the RVU Code update file "
S DIR("?")="/usr/mydir or c:\pub\"
S ERROR=0
D ^DIR
I $D(DIRUT) D EXIT Q
I Y=""!(Y=U)!(Y=(U_U)) D EXIT Q
S XBDIR=X
K DIR
D FNAME
I $G(XBFN)="" G ASK
D RDFILE(XBDIR,XBFN)
I ERROR G ASK
D PLACE
D EXIT
G ASK
Q
; pull up a file into the TMP global for display
RDFILE(XBDIR,XBFN,XBNODE) ;
S ERROR=0
I '$D(XBHDR) S XBHDR=""
N Y,X,I
S Y=$$OPEN^%ZISH(XBDIR,XBFN,"R")
I POP W !,*7,"CANNOT OPEN (OR ACCESS) FILE '",XBDIR,XBFN,"'." S Y=$$DIR^XBDIR("E") S ERROR=1 Q
K ^TMP("ADERVURD",$J)
U 0 W !!,"READING FROM FILE "
F I=1:1 U IO R X:DTIME S X=$TR(X,$C(9),U) Q:X="" S ^TMP("ADERVURD",$J,I,0)=X U 0 W "." Q:$$STATUS^%ZISH=-1
U 0 W !,I," RECORDS READ"
D CLOSE^%ZISH()
Q
;PUT DATA INTO ADA CODE FILE
PLACE ;
W !!,"ADDING RVU INFO TO 'ADA CODE' FILE"
S RECORD=1
F S RECORD=$O(^TMP("ADERVURD",$J,RECORD)) Q:RECORD="" D
.S ADACODE=$TR($P(^TMP("ADERVURD",$J,RECORD,0),U),"D")
.Q:$E(ADACODE,1,2)="IH" ;USER DEFINED SKIP FOR NOW
.S RVU=$P(^TMP("ADERVURD",$J,RECORD,0),U,5) ;GET RELATIVE VALUE UNIT
.S ADANLC=$P(^TMP("ADERVURD",$J,RECORD,0),U,4) ;GET NEW LEVEL OF SERVICE (CARE)
.S ADADESCR=$P(^TMP("ADERVURD",$J,RECORD,0),U,2)
.D ADDTOFIL(ADACODE,RVU,ADADESCR,ADANLC) ;ADD TO THE FILE
I $D(^TMP("ADERVURD","EXCEPTIONS",$J)) D EXCEPTRP ;DO EXCEPTION REPORT
Q
;CLEAN UP
EXIT K ADACODE,ADADESCR,ADAIEN,DA,DIE,DR,ERROR,I,MSG,RECORD,RVU,CENTER,LINE,ADANLC
K ^TMP("ADERVURD",$J)
I $D(^TMP("ADERVURD","EXCEPTIONS",$J)) K ^TMP("ADERVURD","EXCEPTIONS",$J) W !!,"EXCEPTION FILE HAS BEEN DELETED!"
Q
;
;ADD TO THE ADAD CODE FILE
ADDTOFIL(ADACODE,RVU,ADADESCR,ADANLC) ;
W "."
S XREF="BA"
S ADAIEN=$O(^AUTTADA("BA",ADACODE_" ",""))
I ADAIEN="" D EXCEPT("ENTRY FOR "_ADACODE_" NOT FOUND USING "_XREF_" X-REF",ADACODE,ADADESCR)
S XREF="B"
S ADAIEN=$O(^AUTTADA("B",ADACODE,""))
I ADAIEN="" D EXCEPT("INTERNAL ENTRY NUMBER NOT FOUND USING X-REF "_XREF_" FOR ADA CODE "_ADACODE_". RVU HAS NOT BEEN ENTERED INTO FILE",ADACODE,ADADESCR) Q
I $D(^AUTTADA(ADAIEN,0))'=1 D EXCEPT("MISSING ZERO NODE WITH ENTRY FOR "_ADAIEN_" X-REF EXISTS BUT ZERO NODE DOES NOT",ADAIEN,ADADESCR) Q
D UPDATE(ADAIEN,RVU,ADANLC)
Q
;ADD RVU TO ENTRY
UPDATE(ADAIEN,RVU,ADANLC) ;
;UPDATE RVU AND LEVEL OF SERVICE
S DIE="^AUTTADA("
S DA=ADAIEN
S DR=".05///^S X=ADANLC;501///^S X=RVU"
D ^DIE
K DIE
Q
;REPORT/PROCESS EXCEPTION
EXCEPT(MSG,ADACODE,ADADESCR) ;
S ^TMP("ADERVURD","EXCEPTIONS",$J,ADACODE)=MSG_U_ADADESCR
;W !,MSG
Q
;FOLLOWING CODE BORROWED WITH PERMISSION FROM ROUTINE BAREDIUT
FNAME ;
; Select a file (directory can be pre-loaded into XBDIR)
K DIR
;
FNAME1 ;
S XBFN=""
S DIR(0)="FO^1:15"
S DIR("A")="File Name "
D ^DIR
K DIR
Q:$G(DTOUT)
Q:Y["^"
Q:Y=""
I Y?.N,$D(XBFL(Y)) S DIR("B")=XBFL(Y) G FNAME1
I Y["*" D G FNAME
. K XBFL
. S X=$$LIST^%ZISH(XBDIR,Y,.XBFL)
. F XBI=1:1 Q:'$D(XBFL(XBI)) W !?5,XBI,?10,XBFL(XBI) I '(XBI#20) R X:DTIME
S XBFN=Y
Q
;EXCEPTION REPORT
EXCEPTRP ;
W !,"EXCEPTIONS HAVE BEEN FOUND"
K DIR
S DIR(0)="Y"
S DIR("A")="VIEW EXCEPTION REPORT(Y/N)"
S DIR("B")="N"
D ^DIR
Q:'Y
S $P(LINE,"*",IOM+1)=""
D ^%ZIS Q:POP
U IO
D HDR
S ADACODE=""
F S ADACODE=$O(^TMP("ADERVURD","EXCEPTIONS",$J,ADACODE)) Q:ADACODE="" D
.S ADADESCR=$P(^TMP("ADERVURD","EXCEPTIONS",$J,ADACODE),U,2)
.W !!,ADACODE,?10,ADADESCR
.I $Y>(IOSL-4),IOST'[("C-") D HDR Q
.I $Y>(IOSL-4) D RETURN,HDR
I IOST[("C-") D RETURN
W @IOF
D ^%ZISC
Q
HDR ;
W @IOF
S X="EXCEPTION REPORT"
S CENTER=(IOM-$L(X))\2
W !,?CENTER,X
S X="THE FOLLOWING ADA CODES WERE NOT FOUND IN FILE #9999999.31"
S CENTER=(IOM-$L(X))\2
W !,?CENTER,X
W !!,"ADA CODE",?10,"DESCRIPTION"
W !,LINE
Q
RETURN ;EP - Press return to continue
N DIR
S DIR(0)="FAO^1:1",DIR("A")="Press 'Return' to continue... "
W !! D ^DIR
K DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
Q
ADERVURD ;IHS/ITSC/TPF - READ NEW RVUS FROM FILE AND PLACE INTO ADA CODE FILE 8/27/2003 12:50:16 PM
+1 ;;6.0;ADE;**15**;JAN 01, 2004
+2 SET U="^"
ASK WRITE @IOF
+1 KILL DIR
+2 SET DIR("B")=$GET(^XTV(8989.3,1,"DEV"))
+3 SET DIR(0)="FO"
SET DIR("A")="Enter the directory path for the RVU Code update file "
+4 SET DIR("?")="/usr/mydir or c:\pub\"
+5 SET ERROR=0
+6 DO ^DIR
+7 IF $DATA(DIRUT)
DO EXIT
QUIT
+8 IF Y=""!(Y=U)!(Y=(U_U))
DO EXIT
QUIT
+9 SET XBDIR=X
+10 KILL DIR
+11 DO FNAME
+12 IF $GET(XBFN)=""
GOTO ASK
+13 DO RDFILE(XBDIR,XBFN)
+14 IF ERROR
GOTO ASK
+15 DO PLACE
+16 DO EXIT
+17 GOTO ASK
+18 QUIT
+19 ; pull up a file into the TMP global for display
RDFILE(XBDIR,XBFN,XBNODE) ;
+1 SET ERROR=0
+2 IF '$DATA(XBHDR)
SET XBHDR=""
+3 NEW Y,X,I
+4 SET Y=$$OPEN^%ZISH(XBDIR,XBFN,"R")
+5 IF POP
WRITE !,*7,"CANNOT OPEN (OR ACCESS) FILE '",XBDIR,XBFN,"'."
SET Y=$$DIR^XBDIR("E")
SET ERROR=1
QUIT
+6 KILL ^TMP("ADERVURD",$JOB)
+7 USE 0
WRITE !!,"READING FROM FILE "
+8 FOR I=1:1
USE IO
READ X:DTIME
SET X=$TRANSLATE(X,$CHAR(9),U)
IF X=""
QUIT
SET ^TMP("ADERVURD",$JOB,I,0)=X
USE 0
WRITE "."
IF $$STATUS^%ZISH=-1
QUIT
+9 USE 0
WRITE !,I," RECORDS READ"
+10 DO CLOSE^%ZISH()
+11 QUIT
+12 ;PUT DATA INTO ADA CODE FILE
PLACE ;
+1 WRITE !!,"ADDING RVU INFO TO 'ADA CODE' FILE"
+2 SET RECORD=1
+3 FOR
SET RECORD=$ORDER(^TMP("ADERVURD",$JOB,RECORD))
IF RECORD=""
QUIT
Begin DoDot:1
+4 SET ADACODE=$TRANSLATE($PIECE(^TMP("ADERVURD",$JOB,RECORD,0),U),"D")
+5 ;USER DEFINED SKIP FOR NOW
IF $EXTRACT(ADACODE,1,2)="IH"
QUIT
+6 ;GET RELATIVE VALUE UNIT
SET RVU=$PIECE(^TMP("ADERVURD",$JOB,RECORD,0),U,5)
+7 ;GET NEW LEVEL OF SERVICE (CARE)
SET ADANLC=$PIECE(^TMP("ADERVURD",$JOB,RECORD,0),U,4)
+8 SET ADADESCR=$PIECE(^TMP("ADERVURD",$JOB,RECORD,0),U,2)
+9 ;ADD TO THE FILE
DO ADDTOFIL(ADACODE,RVU,ADADESCR,ADANLC)
End DoDot:1
+10 ;DO EXCEPTION REPORT
IF $DATA(^TMP("ADERVURD","EXCEPTIONS",$JOB))
DO EXCEPTRP
+11 QUIT
+12 ;CLEAN UP
EXIT KILL ADACODE,ADADESCR,ADAIEN,DA,DIE,DR,ERROR,I,MSG,RECORD,RVU,CENTER,LINE,ADANLC
+1 KILL ^TMP("ADERVURD",$JOB)
+2 IF $DATA(^TMP("ADERVURD","EXCEPTIONS",$JOB))
KILL ^TMP("ADERVURD","EXCEPTIONS",$JOB)
WRITE !!,"EXCEPTION FILE HAS BEEN DELETED!"
+3 QUIT
+4 ;
+5 ;ADD TO THE ADAD CODE FILE
ADDTOFIL(ADACODE,RVU,ADADESCR,ADANLC) ;
+1 WRITE "."
+2 SET XREF="BA"
+3 SET ADAIEN=$ORDER(^AUTTADA("BA",ADACODE_" ",""))
+4 IF ADAIEN=""
DO EXCEPT("ENTRY FOR "_ADACODE_" NOT FOUND USING "_XREF_" X-REF",ADACODE,ADADESCR)
+5 SET XREF="B"
+6 SET ADAIEN=$ORDER(^AUTTADA("B",ADACODE,""))
+7 IF ADAIEN=""
DO EXCEPT("INTERNAL ENTRY NUMBER NOT FOUND USING X-REF "_XREF_" FOR ADA CODE "_ADACODE_". RVU HAS NOT BEEN ENTERED INTO FILE",ADACODE,ADADESCR)
QUIT
+8 IF $DATA(^AUTTADA(ADAIEN,0))'=1
DO EXCEPT("MISSING ZERO NODE WITH ENTRY FOR "_ADAIEN_" X-REF EXISTS BUT ZERO NODE DOES NOT",ADAIEN,ADADESCR)
QUIT
+9 DO UPDATE(ADAIEN,RVU,ADANLC)
+10 QUIT
+11 ;ADD RVU TO ENTRY
UPDATE(ADAIEN,RVU,ADANLC) ;
+1 ;UPDATE RVU AND LEVEL OF SERVICE
+2 SET DIE="^AUTTADA("
+3 SET DA=ADAIEN
+4 SET DR=".05///^S X=ADANLC;501///^S X=RVU"
+5 DO ^DIE
+6 KILL DIE
+7 QUIT
+8 ;REPORT/PROCESS EXCEPTION
EXCEPT(MSG,ADACODE,ADADESCR) ;
+1 SET ^TMP("ADERVURD","EXCEPTIONS",$JOB,ADACODE)=MSG_U_ADADESCR
+2 ;W !,MSG
+3 QUIT
+4 ;FOLLOWING CODE BORROWED WITH PERMISSION FROM ROUTINE BAREDIUT
FNAME ;
+1 ; Select a file (directory can be pre-loaded into XBDIR)
+2 KILL DIR
+3 ;
FNAME1 ;
+1 SET XBFN=""
+2 SET DIR(0)="FO^1:15"
+3 SET DIR("A")="File Name "
+4 DO ^DIR
+5 KILL DIR
+6 IF $GET(DTOUT)
QUIT
+7 IF Y["^"
QUIT
+8 IF Y=""
QUIT
+9 IF Y?.N
IF $DATA(XBFL(Y))
SET DIR("B")=XBFL(Y)
GOTO FNAME1
+10 IF Y["*"
Begin DoDot:1
+11 KILL XBFL
+12 SET X=$$LIST^%ZISH(XBDIR,Y,.XBFL)
+13 FOR XBI=1:1
IF '$DATA(XBFL(XBI))
QUIT
WRITE !?5,XBI,?10,XBFL(XBI)
IF '(XBI#20)
READ X:DTIME
End DoDot:1
GOTO FNAME
+14 SET XBFN=Y
+15 QUIT
+16 ;EXCEPTION REPORT
EXCEPTRP ;
+1 WRITE !,"EXCEPTIONS HAVE BEEN FOUND"
+2 KILL DIR
+3 SET DIR(0)="Y"
+4 SET DIR("A")="VIEW EXCEPTION REPORT(Y/N)"
+5 SET DIR("B")="N"
+6 DO ^DIR
+7 IF 'Y
QUIT
+8 SET $PIECE(LINE,"*",IOM+1)=""
+9 DO ^%ZIS
IF POP
QUIT
+10 USE IO
+11 DO HDR
+12 SET ADACODE=""
+13 FOR
SET ADACODE=$ORDER(^TMP("ADERVURD","EXCEPTIONS",$JOB,ADACODE))
IF ADACODE=""
QUIT
Begin DoDot:1
+14 SET ADADESCR=$PIECE(^TMP("ADERVURD","EXCEPTIONS",$JOB,ADACODE),U,2)
+15 WRITE !!,ADACODE,?10,ADADESCR
+16 IF $Y>(IOSL-4)
IF IOST'[("C-")
DO HDR
QUIT
+17 IF $Y>(IOSL-4)
DO RETURN
DO HDR
End DoDot:1
+18 IF IOST[("C-")
DO RETURN
+19 WRITE @IOF
+20 DO ^%ZISC
+21 QUIT
HDR ;
+1 WRITE @IOF
+2 SET X="EXCEPTION REPORT"
+3 SET CENTER=(IOM-$LENGTH(X))\2
+4 WRITE !,?CENTER,X
+5 SET X="THE FOLLOWING ADA CODES WERE NOT FOUND IN FILE #9999999.31"
+6 SET CENTER=(IOM-$LENGTH(X))\2
+7 WRITE !,?CENTER,X
+8 WRITE !!,"ADA CODE",?10,"DESCRIPTION"
+9 WRITE !,LINE
+10 QUIT
RETURN ;EP - Press return to continue
+1 NEW DIR
+2 SET DIR(0)="FAO^1:1"
SET DIR("A")="Press 'Return' to continue... "
+3 WRITE !!
DO ^DIR
+4 KILL DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+5 QUIT
