IBDFUTL ;ALB/MAF - Maintenance Utility Routine - APR 20 1995
;;3.0;AUTOMATED INFO COLLECTION SYS;**9,32**;APR 24, 1997
;
; -- Set up variables for display by clinic/form/group
OUT S IBDFL=0 ;W !!,"Display output by: CLINICS// " D ZSET1 S X="" R X:DTIME G QUIT:X="^"!('$T) I X=""!("Cc"[X) S X="1"
S DIR("B")="CLINICS",DIR(0)="SBM^C:CLINICS (Individual);G:GROUPS (Clinics);F:FORMS",DIR("A")="Sort by [C]linics, [G]roups, [F]orms" D ^DIR
K DIR I $D(DIRUT)&('$D(IBDF1))!(Y<0) G EXIT
I $D(DIRUT)&$D(IBDF1) G QUIT
S X=$S("Gg"[X:2,"Ff"[X:3,"Ss"[X:4,1:1)
;I X="?" D ZSET1,HELP1 G OUT
S IBDFSRT=$E(X) ;D IN^DGHELP W ! I %=-1 D ZSET1,HELP1 G OUT
S IBDFDIS=$S(IBDFSRT=1:"CLIN",IBDFSRT=2:"GROUP",IBDFSRT=3:"FORM",1:"QUIT")
D @(IBDFDIS) S:Y=-1 IBDFNCNG=1 G:Y=-1 QUIT
;
;
OUT1 ; -- Ask for what type of package interface
S DIC="^IBE(357.6,",DIC(0)="AEMN"
S DIC("S")="I $P(^(0),U,6)=3,$P(^(0),U,9)=1,$G(^(11))'="""""
S DIC("A")="Select Type of Code to Display: " D ^DIC K DIC G QUIT:Y<0
S IBDFINT=+Y
;
S IBDFACT=2 ;default of Inactive
S X=$E($G(^IBE(357.6,IBDFINT,11)),7,9)
;
; -- for cpt and icd codes, let them choose active or inactive
I X="CPT"!(X="VST")!(X="ICD") D
.S DIR("B")="ACTIVE"
.S DIR(0)="SBM^A:ACTIVE;I:INACTIVE"
.S DIR("A")="Display codes [A]ctive, [I]nactive"
.D ^DIR K DIR
.Q:$D(DIRUT)
.S X=$S("Ii"[$E(X,1):2,1:1)
.S IBDFACT=$E(X)
I $D(DIRUT)&('$D(IBDF1))!(Y<0) G EXIT
I $D(DIRUT)&$D(IBDF1) G QUIT
;
I $D(IBDF1) D
.K VAUTP F IBI=0:0 S IBI=$O(VAUTJ(IBI)) Q:IBI']"" S VAUTP(IBI)=$G(VAUTJ(IBI))
I IBDFACT=1 D
.I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="CPT" S DIC="^ICPT(",IBDFCODE="CPT "
.I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="ICD" S DIC="^ICD9(",IBDFCODE="ICD-9 "
.I $E($G(^IBE(357.6,IBDFINT,11)),7,9)="VST" S DIC="^IBE(357.69,",IBDFCODE="Type of Visit "
.I $G(DIC)]"" S VAUTVB="VAUTJ",VAUTNI=2,VAUTSTR=IBDFCODE_"code" S VAUTNALL=1 D FIRST^VAUTOMA
;
I (Y<0)&$D(IBDF1) D K VAUTP G QUIT
.F IBI=0:0 S IBI=$O(VAUTP(IBI)) Q:IBI']"" S VAUTJ(IBI)=$G(VAUTP(IBI))
I IBDFACT=1,Y<0,'$D(IBDF1) G EXIT
;
I '$D(IBDF1) K XQORS,VALMEVL D EN^VALM("IBDF UTIL PRIMARY SCREEN")
I $D(IBDF1) D HDR,KILL,INIT S VALMBCK="R",VALMBG=1
Q
;
HDR ; -- header code
I IBDFACT=1 D
.S VALMHDR(1)="This screen lists Active codes on Encounter Forms."
I IBDFACT'=1 D
.S VALMHDR(1)="This screen lists Inactive codes on Encounter Forms."
Q
;
; -- Set up list
INIT D FULL^VALM1 S (IBDCNT,IBDCNT1,VALMCNT)=0
K ^TMP("CPT",$J),^TMP("CPTIDX",$J) D KILL^VALM10()
S IBDFCNT1=0 D @(IBDFDIS_"1^IBDFUTL1")
I '$D(^TMP("CPT",$J)) D NUL
Q
;
; -- Ask for clinics one/many/all
CLIN S VAUTVB="VAUTC",DIC="^SC(",DIC("S")="I $P(^(0),U,3)=""C""",VAUTSTR="Clinic",VAUTNI=2 D FIRST^VAUTOMA K DIC S:Y=-1 IBDFL=1 Q:IBDFL
Q
;
; -- Ask for forms one/many/all
FORM S VAUTVB="VAUTF",DIC="^IBE(357,",VAUTSTR="Form",VAUTNI=2 D FIRST^VAUTOMA S:Y=-1 IBDFL=1 Q:IBDFL
Q
;
; -- Ask for clinic groups one/many/all
GROUP S VAUTVB="VAUTG",DIC="^IBD(357.99,",VAUTSTR="Clinic Group",VAUTNI=2 D FIRST^VAUTOMA S:Y=-1 IBDFL=1 Q:IBDFL
Q
;
; -- Ask for divisions one/many/all
DIV S IBDFL=0 D DIVISION^VAUTOMA
S:Y=-1 IBDFL=1 Q:IBDFL
Q
; -- Help for display choices
HELP1 W !!,"Choose a number or first initial :" F K=2:1:4 W !?15,$P(Z,"^",K)
W ! Q
;
; -- Listing of selections
ZSET1 S Z="^1 [C]LINICS (Individual)^2 [G]ROUPS (CLINIC)^3 [F]ORMS^" Q
;
;
QUIT ; -- Kill variables and reset to last display if no change has been taken place.
I $D(IBDF1) S IBDFDIS=IBDFDIS1,IBDFINT=IBDFINT1,IBDFACT=IBDFACT1
I '$D(IBDF1) G EXIT
D KILL,INIT K IBDFNCNG S VALMBCK="R",VALMBG=1
Q
;
;
KILL ; -- Kill extra array variables
N IBDFXX
S IBDFXX=$S(IBDFDIS="FORM":"VAUTF",IBDFDIS="GROUP":"VAUTG",1:"VAUTC")
I IBDFXX="VAUTF" K VAUTG,VAUTC,^TMP("CLN",$J),^TMP("CLN1",$J),^TMP("GRP",$J),^TMP("GRP1",$J)
I IBDFXX="VAUTC" K VAUTG,VAUTF,^TMP("FRM",$J),^TMP("FRM1",$J),^TMP("GRP1",$J)
I IBDFXX="VAUTG" K VAUTC,VAUTF,^TMP("FRM",$J),^TMP("FRM1",$J),^TMP("CLN",$J),^TMP("CLN1",$J)
Q
;
;
EXIT ; -- Code executed at action exit
K IBDFDIS,IBDFINT,VAUTC,VAUTF,VAUTG,VAUTJ,VAUTP,IBDFINT1,IBDFDIS1,^TMP("CLN",$J),IBDFCODE,IBI,IBDFACT1
EXIT1 K DIC,IBDBLK,IBDCLN,IBDCLNM,IBDCNODE,IBDCNT,IBDCNT1,IBDF,IBDFBK,IBDFCIFN,IBDFCLIN,IBDFL,IBDFLG,IBDFN,IBDFNAME,IBDFNM,IBDFNODE,IBDFORM1,IBDFRM,IBDFSEL,IBDFSRT,IBDFTMP,IBDFVAL
K IBDFX,IBDORM,IBDVAL,IBDVAL1,IBDFCNT1,Z,IBDFRNM,IBDFX1,IBDFX2,IBDFX3
K IBCLN,IBDFCLN,IBDFCLNM,IBDFDIV,IBDFGIFN,IBDFGN,IBDFGNM,IBDIV,IBDNAM,IBDNAME,IEN,^TMP("IBDF",$J),^TMP("UTIL",$J),^TMP("CPT",$J),^TMP("CPTIDX",$J),DIVISION,IBDF,IBDFACT,VAUTNALL Q
;
;
HLP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
;
EXP ; -- expand code
Q
NUL ; -- NULL MESSAGE
S ^TMP("CPT",$J,1,0)=" ",^TMP("CPT",$J,2,0)="There are no "_$S(IBDFACT=1:"active",1:"inactive")_" codes on any forms.",^TMP("CPTIDX",$J,1)=1,^TMP("CPTIDX",$J,2)=2
Q
IBDFUTL ;ALB/MAF - Maintenance Utility Routine - APR 20 1995
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**9,32**;APR 24, 1997
+2 ;
+3 ; -- Set up variables for display by clinic/form/group
OUT ;W !!,"Display output by: CLINICS// " D ZSET1 S X="" R X:DTIME G QUIT:X="^"!('$T) I X=""!("Cc"[X) S X="1"
SET IBDFL=0
+1 SET DIR("B")="CLINICS"
SET DIR(0)="SBM^C:CLINICS (Individual);G:GROUPS (Clinics);F:FORMS"
SET DIR("A")="Sort by [C]linics, [G]roups, [F]orms"
DO ^DIR
+2 KILL DIR
IF $DATA(DIRUT)&('$DATA(IBDF1))!(Y<0)
GOTO EXIT
+3 IF $DATA(DIRUT)&$DATA(IBDF1)
GOTO QUIT
+4 SET X=$SELECT("Gg"[X:2,"Ff"[X:3,"Ss"[X:4,1:1)
+5 ;I X="?" D ZSET1,HELP1 G OUT
+6 ;D IN^DGHELP W ! I %=-1 D ZSET1,HELP1 G OUT
SET IBDFSRT=$EXTRACT(X)
+7 SET IBDFDIS=$SELECT(IBDFSRT=1:"CLIN",IBDFSRT=2:"GROUP",IBDFSRT=3:"FORM",1:"QUIT")
+8 DO @(IBDFDIS)
IF Y=-1
SET IBDFNCNG=1
IF Y=-1
GOTO QUIT
+9 ;
+10 ;
OUT1 ; -- Ask for what type of package interface
+1 SET DIC="^IBE(357.6,"
SET DIC(0)="AEMN"
+2 SET DIC("S")="I $P(^(0),U,6)=3,$P(^(0),U,9)=1,$G(^(11))'="""""
+3 SET DIC("A")="Select Type of Code to Display: "
DO ^DIC
KILL DIC
IF Y<0
GOTO QUIT
+4 SET IBDFINT=+Y
+5 ;
+6 ;default of Inactive
SET IBDFACT=2
+7 SET X=$EXTRACT($GET(^IBE(357.6,IBDFINT,11)),7,9)
+8 ;
+9 ; -- for cpt and icd codes, let them choose active or inactive
+10 IF X="CPT"!(X="VST")!(X="ICD")
Begin DoDot:1
+11 SET DIR("B")="ACTIVE"
+12 SET DIR(0)="SBM^A:ACTIVE;I:INACTIVE"
+13 SET DIR("A")="Display codes [A]ctive, [I]nactive"
+14 DO ^DIR
KILL DIR
+15 IF $DATA(DIRUT)
QUIT
+16 SET X=$SELECT("Ii"[$EXTRACT(X,1):2,1:1)
+17 SET IBDFACT=$EXTRACT(X)
End DoDot:1
+18 IF $DATA(DIRUT)&('$DATA(IBDF1))!(Y<0)
GOTO EXIT
+19 IF $DATA(DIRUT)&$DATA(IBDF1)
GOTO QUIT
+20 ;
+21 IF $DATA(IBDF1)
Begin DoDot:1
+22 KILL VAUTP
FOR IBI=0:0
SET IBI=$ORDER(VAUTJ(IBI))
IF IBI']""
QUIT
SET VAUTP(IBI)=$GET(VAUTJ(IBI))
End DoDot:1
+23 IF IBDFACT=1
Begin DoDot:1
+24 IF $EXTRACT($GET(^IBE(357.6,IBDFINT,11)),7,9)="CPT"
SET DIC="^ICPT("
SET IBDFCODE="CPT "
+25 IF $EXTRACT($GET(^IBE(357.6,IBDFINT,11)),7,9)="ICD"
SET DIC="^ICD9("
SET IBDFCODE="ICD-9 "
+26 IF $EXTRACT($GET(^IBE(357.6,IBDFINT,11)),7,9)="VST"
SET DIC="^IBE(357.69,"
SET IBDFCODE="Type of Visit "
+27 IF $GET(DIC)]""
SET VAUTVB="VAUTJ"
SET VAUTNI=2
SET VAUTSTR=IBDFCODE_"code"
SET VAUTNALL=1
DO FIRST^VAUTOMA
End DoDot:1
+28 ;
+29 IF (Y<0)&$DATA(IBDF1)
Begin DoDot:1
+30 FOR IBI=0:0
SET IBI=$ORDER(VAUTP(IBI))
IF IBI']""
QUIT
SET VAUTJ(IBI)=$GET(VAUTP(IBI))
End DoDot:1
KILL VAUTP
GOTO QUIT
+31 IF IBDFACT=1
IF Y<0
IF '$DATA(IBDF1)
GOTO EXIT
+32 ;
+33 IF '$DATA(IBDF1)
KILL XQORS,VALMEVL
DO EN^VALM("IBDF UTIL PRIMARY SCREEN")
+34 IF $DATA(IBDF1)
DO HDR
DO KILL
DO INIT
SET VALMBCK="R"
SET VALMBG=1
+35 QUIT
+36 ;
HDR ; -- header code
+1 IF IBDFACT=1
Begin DoDot:1
+2 SET VALMHDR(1)="This screen lists Active codes on Encounter Forms."
End DoDot:1
+3 IF IBDFACT'=1
Begin DoDot:1
+4 SET VALMHDR(1)="This screen lists Inactive codes on Encounter Forms."
End DoDot:1
+5 QUIT
+6 ;
+7 ; -- Set up list
INIT DO FULL^VALM1
SET (IBDCNT,IBDCNT1,VALMCNT)=0
+1 KILL ^TMP("CPT",$JOB),^TMP("CPTIDX",$JOB)
DO KILL^VALM10()
+2 SET IBDFCNT1=0
DO @(IBDFDIS_"1^IBDFUTL1")
+3 IF '$DATA(^TMP("CPT",$JOB))
DO NUL
+4 QUIT
+5 ;
+6 ; -- Ask for clinics one/many/all
CLIN SET VAUTVB="VAUTC"
SET DIC="^SC("
SET DIC("S")="I $P(^(0),U,3)=""C"""
SET VAUTSTR="Clinic"
SET VAUTNI=2
DO FIRST^VAUTOMA
KILL DIC
IF Y=-1
SET IBDFL=1
IF IBDFL
QUIT
+1 QUIT
+2 ;
+3 ; -- Ask for forms one/many/all
FORM SET VAUTVB="VAUTF"
SET DIC="^IBE(357,"
SET VAUTSTR="Form"
SET VAUTNI=2
DO FIRST^VAUTOMA
IF Y=-1
SET IBDFL=1
IF IBDFL
QUIT
+1 QUIT
+2 ;
+3 ; -- Ask for clinic groups one/many/all
GROUP SET VAUTVB="VAUTG"
SET DIC="^IBD(357.99,"
SET VAUTSTR="Clinic Group"
SET VAUTNI=2
DO FIRST^VAUTOMA
IF Y=-1
SET IBDFL=1
IF IBDFL
QUIT
+1 QUIT
+2 ;
+3 ; -- Ask for divisions one/many/all
DIV SET IBDFL=0
DO DIVISION^VAUTOMA
+1 IF Y=-1
SET IBDFL=1
IF IBDFL
QUIT
+2 QUIT
+3 ; -- Help for display choices
HELP1 WRITE !!,"Choose a number or first initial :"
FOR K=2:1:4
WRITE !?15,$PIECE(Z,"^",K)
+1 WRITE !
QUIT
+2 ;
+3 ; -- Listing of selections
ZSET1 SET Z="^1 [C]LINICS (Individual)^2 [G]ROUPS (CLINIC)^3 [F]ORMS^"
QUIT
+1 ;
+2 ;
QUIT ; -- Kill variables and reset to last display if no change has been taken place.
+1 IF $DATA(IBDF1)
SET IBDFDIS=IBDFDIS1
SET IBDFINT=IBDFINT1
SET IBDFACT=IBDFACT1
+2 IF '$DATA(IBDF1)
GOTO EXIT
+3 DO KILL
DO INIT
KILL IBDFNCNG
SET VALMBCK="R"
SET VALMBG=1
+4 QUIT
+5 ;
+6 ;
KILL ; -- Kill extra array variables
+1 NEW IBDFXX
+2 SET IBDFXX=$SELECT(IBDFDIS="FORM":"VAUTF",IBDFDIS="GROUP":"VAUTG",1:"VAUTC")
+3 IF IBDFXX="VAUTF"
KILL VAUTG,VAUTC,^TMP("CLN",$JOB),^TMP("CLN1",$JOB),^TMP("GRP",$JOB),^TMP("GRP1",$JOB)
+4 IF IBDFXX="VAUTC"
KILL VAUTG,VAUTF,^TMP("FRM",$JOB),^TMP("FRM1",$JOB),^TMP("GRP1",$JOB)
+5 IF IBDFXX="VAUTG"
KILL VAUTC,VAUTF,^TMP("FRM",$JOB),^TMP("FRM1",$JOB),^TMP("CLN",$JOB),^TMP("CLN1",$JOB)
+6 QUIT
+7 ;
+8 ;
EXIT ; -- Code executed at action exit
+1 KILL IBDFDIS,IBDFINT,VAUTC,VAUTF,VAUTG,VAUTJ,VAUTP,IBDFINT1,IBDFDIS1,^TMP("CLN",$JOB),IBDFCODE,IBI,IBDFACT1
EXIT1 KILL DIC,IBDBLK,IBDCLN,IBDCLNM,IBDCNODE,IBDCNT,IBDCNT1,IBDF,IBDFBK,IBDFCIFN,IBDFCLIN,IBDFL,IBDFLG,IBDFN,IBDFNAME,IBDFNM,IBDFNODE,IBDFORM1,IBDFRM,IBDFSEL,IBDFSRT,IBDFTMP,IBDFVAL
+1 KILL IBDFX,IBDORM,IBDVAL,IBDVAL1,IBDFCNT1,Z,IBDFRNM,IBDFX1,IBDFX2,IBDFX3
+2 KILL IBCLN,IBDFCLN,IBDFCLNM,IBDFDIV,IBDFGIFN,IBDFGN,IBDFGNM,IBDIV,IBDNAM,IBDNAME,IEN,^TMP("IBDF",$JOB),^TMP("UTIL",$JOB),^TMP("CPT",$JOB),^TMP("CPTIDX",$JOB),DIVISION,IBDF,IBDFACT,VAUTNALL
QUIT
+3 ;
+4 ;
HLP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
+4 ;
EXP ; -- expand code
+1 QUIT
NUL ; -- NULL MESSAGE
+1 SET ^TMP("CPT",$JOB,1,0)=" "
SET ^TMP("CPT",$JOB,2,0)="There are no "_$SELECT(IBDFACT=1:"active",1:"inactive")_" codes on any forms."
SET ^TMP("CPTIDX",$JOB,1)=1
SET ^TMP("CPTIDX",$JOB,2)=2
+2 QUIT
