IBDFUTL.m

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