IBDFUTL2 ;ALB/MAF - MAINTENANCE UTILITY CONT. - 4/24/95
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
;
ENDV ; -- Entire divisions were choosen, find all clinics (with encounter forms defined)
N IBCLN,IBDIV,NODE,DIVISION,ALL
; -- Make a list of the divisions chosen
S IBDFGNM=0 F IBDFGN=0:0 S IBDFGNM=$O(^TMP("IBDF",$J,"D",IBDFGNM)) Q:IBDFGNM']"" S IBDIV=0 F S IBDIV=$O(^TMP("IBDF",$J,"D",IBDFGNM,IBDIV)) Q:'IBDIV S DIVISION(IBDIV,IBDFGNM)=""
;
; -- Loop through all the clinics finding ones in selected divisions
S IBCLN="" F S IBCLN=$O(^SC(IBCLN)) Q:IBCLN="" D
.S NODE=$G(^SC(IBCLN,0))
.S IBDIV=$P(NODE,"^",15)
.I IBDIV Q:'$D(DIVISION(IBDIV))
.; -- Check that location is a clinic
.Q:$P(NODE,"^",3)'="C"
.; -- It passed all the tests, put it on the list
.S IBDNAM=0 F IBDFDIV=0:0 S IBDFDIV=$O(DIVISION(IBDFDIV)) Q:'IBDFDIV I IBDFDIV=IBDIV F IBDNAME=0:0 S IBDNAM=$O(DIVISION(IBDFDIV,IBDNAM)) Q:IBDNAM']"" S ^TMP("IBDF",$J,"C",IBDNAM,$P(^SC(IBCLN,0),"^",1))=IBCLN
;
; -- Don't need list of divisions anymore
K ^TMP("IBDF",$J,"D")
Q
;
;
CLINICS ; -- Clinics that use the form
N IBDFFLG
S IBDFFLG=0 F IDX="C","D","E","F","G","H","I","J" D
.S SETUP="" F S SETUP=$O(^SD(409.95,IDX,IBDFORM1,SETUP)) Q:'SETUP D
..S CLINIC=$P($G(^SD(409.95,SETUP,0)),"^",1)
..Q:'CLINIC
..S NAME=$P($G(^SC(CLINIC,0)),"^",1)
..Q:NAME=""
..S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
..D:'IBDFFLG TMP1 S:IBDFFLG X="" S X=$$SETSTR^VALM1($E(NAME,1,20),X,66,14) D TMP^IBDFUTL1,CNTRL^VALM10(VALMCNT,37,29,IOINHI,IOINORM,0) S IBDFFLG=1
Q
;
;
TMP1 ; -- Text display set up of TMP array
S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S X=$$SETSTR^VALM1(" ",X,1,80) D TMP^IBDFUTL1
S X="",X=$$SETSTR^VALM1("CLINICS USING THIS FORM ARE: ",X,37,29)
Q
;
;
S IBDCNT1=IBDCNT1+1
S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S X=""
S IBDF(IBDFNAME)=IBDCNT_"^"_IBDFORM1
S X=$$SETSTR^VALM1(" ",X,1,3) D TMP^IBDFUTL1
S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S IBDVAL=IBDFNAME
S IBDVAL1=$L(IBDVAL) S IBDVAL1=(80-IBDVAL1)/2 S IBDVAL1=IBDVAL1\1 S X=$$SETSTR^VALM1(" ",X,1,IBDVAL1)
S X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25) D TMP^IBDFUTL1,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S X=$$SETSTR^VALM1(" ",X,1,3) D TMP^IBDFUTL1
S IBDCNT1=IBDCNT1-1
Q
;
;
JUMP ; -- Jump action to display a specific clinic group on the screen.
D FULL^VALM1
I $D(XQORNOD(0)),$P(XQORNOD(0),"^",4)]"" S X=$P(XQORNOD(0),"^",4) S X=$P(X,"=",2) I X]"" D:X?1.6N JSEL S DIC=$S($D(VAUTF):"^IBE(357,",$D(VAUTG):"^IBD(357.99,",1:"^SC("),DIC(0)="QEZ" D ^DIC K DIC G:Y<0 JMP S Y=+Y D JUMP1 Q
JMP S DIC=$S($D(VAUTF):"^IBE(357,",$D(VAUTG):"^IBD(357.99,",1:"^SC("),DIC(0)="AEMN",DIC("A")="Select "_$S($D(VAUTF):"Form",$D(VAUTG):"Clinic Group",1:"Clinic")_" you wish to move to: "
S:$D(VAUTC) DIC("S")="I $P(^SC(+Y,0),U,3)=""C""" D ^DIC K DIC
I X["^" S VALMBG=1,VALMBCK="R" Q
;
;
JUMP1 I Y<0 G JUMP
N IBDFCAT
S IBDFCAT=$S($D(VAUTF):$P(^IBE(357,+Y,0),"^",1),$D(VAUTG):$P(^IBD(357.99,+Y,0),"^",1),1:$P(^SC(+Y,0),"^",1))
I '$D(IBDF(IBDFCAT)) W !!,"There is no data listed for this Clinic Group" G JMP
S VALMBG=+IBDF(IBDFCAT) S VALMBCK="R" Q
Q
;
;
JSEL ; -- Convert number selected to name
S IBDVALM=X I $D(^TMP("CGIDX",$J,IBDVALM)) S X=$P(^TMP("CGIDX",$J,IBDVALM),"^",2),X=$P(^IBD(357.99,X,0),"^",1)
Q
;
;
CHGLST ; -- Code to change list display
D FULL^VALM1
S IBDFDIS1=IBDFDIS,IBDFINT1=IBDFINT,IBDFACT1=IBDFACT
D EXIT1^IBDFUTL,OUT^IBDFUTL
Q
;
;
DELETE ; -- Delete invalid code from the selection list/block
N IBDFVALM,VALMY,IBBLK,IBFORM,DA
S VALMBCK=""
D EN^VALM2($G(XQORNOD(0))) G REP:'$O(VALMY(0)) S IBDFVALM=0
D FULL^VALM1 S VALMBCK="R"
F IBDFVALM=0:0 S IBDFVALM=$O(VALMY(IBDFVALM)) Q:IBDFVALM']"" S DA=$P($G(^TMP("CPTIDX",$J,IBDFVALM)),"^",4) I DA]"" S IBFORM=$P($G(^TMP("CPTIDX",$J,IBDFVALM)),"^",5),IBBLK=$P($G(^TMP("CPTIDX",$J,IBDFVALM)),"^",6) D
.S DIK="^IBE(357.3,",DA=DA D ^DIK K DIK D BLKCHNG^IBDF19(IBFORM,IBBLK)
K IBDF,^TMP("UTIL",$J)
;
; -- Redo list
REP K IBDF D INIT^IBDFUTL S VALMBG=1,VALMBCK="R"
Q
IBDFUTL2 ;ALB/MAF - MAINTENANCE UTILITY CONT. - 4/24/95
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
+3 ;
ENDV ; -- Entire divisions were choosen, find all clinics (with encounter forms defined)
+1 NEW IBCLN,IBDIV,NODE,DIVISION,ALL
+2 ; -- Make a list of the divisions chosen
+3 SET IBDFGNM=0
FOR IBDFGN=0:0
SET IBDFGNM=$ORDER(^TMP("IBDF",$JOB,"D",IBDFGNM))
IF IBDFGNM']""
QUIT
SET IBDIV=0
FOR
SET IBDIV=$ORDER(^TMP("IBDF",$JOB,"D",IBDFGNM,IBDIV))
IF 'IBDIV
QUIT
SET DIVISION(IBDIV,IBDFGNM)=""
+4 ;
+5 ; -- Loop through all the clinics finding ones in selected divisions
+6 SET IBCLN=""
FOR
SET IBCLN=$ORDER(^SC(IBCLN))
IF IBCLN=""
QUIT
Begin DoDot:1
+7 SET NODE=$GET(^SC(IBCLN,0))
+8 SET IBDIV=$PIECE(NODE,"^",15)
+9 IF IBDIV
IF '$DATA(DIVISION(IBDIV))
QUIT
+10 ; -- Check that location is a clinic
+11 IF $PIECE(NODE,"^",3)'="C"
QUIT
+12 ; -- It passed all the tests, put it on the list
+13 SET IBDNAM=0
FOR IBDFDIV=0:0
SET IBDFDIV=$ORDER(DIVISION(IBDFDIV))
IF 'IBDFDIV
QUIT
IF IBDFDIV=IBDIV
FOR IBDNAME=0:0
SET IBDNAM=$ORDER(DIVISION(IBDFDIV,IBDNAM))
IF IBDNAM']""
QUIT
SET ^TMP("IBDF",$JOB,"C",IBDNAM,$PIECE(^SC(IBCLN,0),"^",1))=IBCLN
End DoDot:1
+14 ;
+15 ; -- Don't need list of divisions anymore
+16 KILL ^TMP("IBDF",$JOB,"D")
+17 QUIT
+18 ;
+19 ;
CLINICS ; -- Clinics that use the form
+1 NEW IBDFFLG
+2 SET IBDFFLG=0
FOR IDX="C","D","E","F","G","H","I","J"
Begin DoDot:1
+3 SET SETUP=""
FOR
SET SETUP=$ORDER(^SD(409.95,IDX,IBDFORM1,SETUP))
IF 'SETUP
QUIT
Begin DoDot:2
+4 SET CLINIC=$PIECE($GET(^SD(409.95,SETUP,0)),"^",1)
+5 IF 'CLINIC
QUIT
+6 SET NAME=$PIECE($GET(^SC(CLINIC,0)),"^",1)
+7 IF NAME=""
QUIT
+8 SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+9 IF 'IBDFFLG
DO TMP1
IF IBDFFLG
SET X=""
SET X=$$SETSTR^VALM1($EXTRACT(NAME,1,20),X,66,14)
DO TMP^IBDFUTL1
DO CNTRL^VALM10(VALMCNT,37,29,IOINHI,IOINORM,0)
SET IBDFFLG=1
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
+12 ;
TMP1 ; -- Text display set up of TMP array
+1 SET X=""
SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+2 SET X=$$SETSTR^VALM1(" ",X,1,80)
DO TMP^IBDFUTL1
+3 SET X=""
SET X=$$SETSTR^VALM1("CLINICS USING THIS FORM ARE: ",X,37,29)
+4 QUIT
+5 ;
+6 ;
+1 SET IBDCNT1=IBDCNT1+1
+2 SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+3 SET X=""
+4 SET IBDF(IBDFNAME)=IBDCNT_"^"_IBDFORM1
+5 SET X=$$SETSTR^VALM1(" ",X,1,3)
DO TMP^IBDFUTL1
+6 SET X=""
SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+7 SET IBDVAL=IBDFNAME
+8 SET IBDVAL1=$LENGTH(IBDVAL)
SET IBDVAL1=(80-IBDVAL1)/2
SET IBDVAL1=IBDVAL1\1
SET X=$$SETSTR^VALM1(" ",X,1,IBDVAL1)
+9 SET X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25)
DO TMP^IBDFUTL1
DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
+10 SET X=""
SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+11 SET X=$$SETSTR^VALM1(" ",X,1,3)
DO TMP^IBDFUTL1
+12 SET IBDCNT1=IBDCNT1-1
+13 QUIT
+14 ;
+15 ;
JUMP ; -- Jump action to display a specific clinic group on the screen.
+1 DO FULL^VALM1
+2 IF $DATA(XQORNOD(0))
IF $PIECE(XQORNOD(0),"^",4)]""
SET X=$PIECE(XQORNOD(0),"^",4)
SET X=$PIECE(X,"=",2)
IF X]""
IF X?1.6N
DO JSEL
SET DIC=$SELECT($DATA(VAUTF):"^IBE(357,",$DATA(VAUTG):"^IBD(357.99,",1:"^SC(")
SET DIC(0)="QEZ"
DO ^DIC
KILL DIC
IF Y<0
GOTO JMP
SET Y=+Y
DO JUMP1
QUIT
JMP SET DIC=$SELECT($DATA(VAUTF):"^IBE(357,",$DATA(VAUTG):"^IBD(357.99,",1:"^SC(")
SET DIC(0)="AEMN"
SET DIC("A")="Select "_$SELECT($DATA(VAUTF):"Form",$DATA(VAUTG):"Clinic Group",1:"Clinic")_" you wish to move to: "
+1 IF $DATA(VAUTC)
SET DIC("S")="I $P(^SC(+Y,0),U,3)=""C"""
DO ^DIC
KILL DIC
+2 IF X["^"
SET VALMBG=1
SET VALMBCK="R"
QUIT
+3 ;
+4 ;
JUMP1 IF Y<0
GOTO JUMP
+1 NEW IBDFCAT
+2 SET IBDFCAT=$SELECT($DATA(VAUTF):$PIECE(^IBE(357,+Y,0),"^",1),$DATA(VAUTG):$PIECE(^IBD(357.99,+Y,0),"^",1),1:$PIECE(^SC(+Y,0),"^",1))
+3 IF '$DATA(IBDF(IBDFCAT))
WRITE !!,"There is no data listed for this Clinic Group"
GOTO JMP
+4 SET VALMBG=+IBDF(IBDFCAT)
SET VALMBCK="R"
QUIT
+5 QUIT
+6 ;
+7 ;
JSEL ; -- Convert number selected to name
+1 SET IBDVALM=X
IF $DATA(^TMP("CGIDX",$JOB,IBDVALM))
SET X=$PIECE(^TMP("CGIDX",$JOB,IBDVALM),"^",2)
SET X=$PIECE(^IBD(357.99,X,0),"^",1)
+2 QUIT
+3 ;
+4 ;
CHGLST ; -- Code to change list display
+1 DO FULL^VALM1
+2 SET IBDFDIS1=IBDFDIS
SET IBDFINT1=IBDFINT
SET IBDFACT1=IBDFACT
+3 DO EXIT1^IBDFUTL
DO OUT^IBDFUTL
+4 QUIT
+5 ;
+6 ;
DELETE ; -- Delete invalid code from the selection list/block
+1 NEW IBDFVALM,VALMY,IBBLK,IBFORM,DA
+2 SET VALMBCK=""
+3 DO EN^VALM2($GET(XQORNOD(0)))
IF '$ORDER(VALMY(0))
GOTO REP
SET IBDFVALM=0
+4 DO FULL^VALM1
SET VALMBCK="R"
+5 FOR IBDFVALM=0:0
SET IBDFVALM=$ORDER(VALMY(IBDFVALM))
IF IBDFVALM']""
QUIT
SET DA=$PIECE($GET(^TMP("CPTIDX",$JOB,IBDFVALM)),"^",4)
IF DA]""
SET IBFORM=$PIECE($GET(^TMP("CPTIDX",$JOB,IBDFVALM)),"^",5)
SET IBBLK=$PIECE($GET(^TMP("CPTIDX",$JOB,IBDFVALM)),"^",6)
Begin DoDot:1
+6 SET DIK="^IBE(357.3,"
SET DA=DA
DO ^DIK
KILL DIK
DO BLKCHNG^IBDF19(IBFORM,IBBLK)
End DoDot:1
+7 KILL IBDF,^TMP("UTIL",$JOB)
+8 ;
+9 ; -- Redo list
REP KILL IBDF
DO INIT^IBDFUTL
SET VALMBG=1
SET VALMBCK="R"
+1 QUIT
