- 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
