IBDFCG ;MAF/ALB - CLINIC GROUP FORMS SCREEN ; 09-FEB-1995
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
;
EN ; -- main entry point for IBDF EF CLINIC GROUP LT
D EN^VALM("IBDF EF CLINIC GROUP LT")
Q
;
;
HDR ; -- header code
S VALMHDR(1)="This is a list of the Clinic Groups and the Clinics"
S VALMHDR(2)="and Divisions under them."
Q
;
;
INIT ; -- init variables and list array
N IBDFNODE,IBDFCL,IBDIFN,IBDFCGNM,IBDFCNUM,IBDCNT,IBDCNT1,IBDVAL,IBDVAL1,IBDFVAL,IBFASTXT,IBDCG,IBDCL,IBDDV,IBDFCFLG,IBDFCIEN,IBDFCN,IBDFDFLG,IBDFDIEN,IBDFGN,IBDFX,IBDVALM
K IBDCLN1,IBDFCG
S (IBDCNT,IBFASTXT,IBDCNT1,VALMCNT)=0
K ^TMP("IBMF",$J),^TMP("IBDFCG",$J),^TMP("CGIDX",$J),IBDCLN D KILL^VALM10()
S (IBDFGN,IBDFCGNM)=0
F IBDFGN=0:0 S IBDFCGNM=$O(^IBD(357.99,"B",IBDFCGNM)) Q:IBDFCGNM']"" F IBDIFN=0:0 S IBDIFN=$O(^IBD(357.99,"B",IBDFCGNM,IBDIFN)) Q:IBDIFN'>0 I IBDIFN]"" D ARRAY
S (IBDFCG,IBDFCGNM)=0
F IBDFCN=0:0 S IBDFCGNM=$O(IBDCLN1(IBDFCGNM)) Q:IBDFCGNM']"" F IBDCG=0:0 S IBDCG=$O(IBDCLN1(IBDFCGNM,IBDCG)) Q:'IBDCG I $D(IBDCLN1(IBDFCGNM,IBDCG)) S IBDCNT1=IBDCNT1+1 D GROUPS D
.F IBDFX=IBDFX:0 S IBDFX=$O(^TMP("IBMF",$J,IBDCG,IBDFX)) Q:'IBDFX D SETG1
.I $O(IBDCLN1(IBDFCGNM))]"" S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1 S X="",X=$$SETSTR^VALM1(X,X,1,80) D TMP
;
I '$D(^TMP("IBDFCG",$J)) D NUL
Q
;
;
ARRAY ; -- Setting up array for clinic groups and the divisions and clinics
S IBDCLN1(IBDFCGNM,IBDIFN)=IBDIFN
S (IBDDV,IBDCL)=0 D CLIN^IBDFCG1 D DIV^IBDFCG1
S (IBDFX,IBDDV,IBDCL,IBDFCFLG,IBDFDFLG,IBDFCIEN,IBDFDIEN)=0
F IBDFX=0:0 S IBDFX=IBDFX+1 D:'IBDFCFLG CLIN1^IBDFCG1 D:'IBDFDFLG DIV1^IBDFCG1 Q:IBDFCFLG=1&(IBDFDFLG=1)
Q
;
;
SETG1 ; -- Creating the list entries
S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S X=""
S IBDFVAL=$O(^TMP("IBMF",$J,IBDCG,IBDFX,"D",0))
S IBDFVAL=$G(^TMP("IBMF",$J,IBDCG,IBDFX,"D",+IBDFVAL)) S X=$$SETSTR^VALM1(IBDFVAL,X,28,26)
S IBDFVAL=$O(^TMP("IBMF",$J,IBDCG,IBDFX,"C",0))
S IBDFVAL=$G(^TMP("IBMF",$J,IBDCG,IBDFX,"C",+IBDFVAL)) S X=$$SETSTR^VALM1(IBDFVAL,X,56,23)
D TMP
Q
;
;
GROUPS ; -- Creating the Listman Clinic Name titles for the list
S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
S IBDFCG(IBDFCGNM)=IBDCNT_"^"_IBDCG
S X="",X=$$SETSTR^VALM1(IBDCNT1_" "_IBDFCGNM,X,1,26)
S IBDFX=1
I '$O(^TMP("IBMF",$J,IBDCG,IBDFX,"D",0)),'$O(^TMP("IBMF",$J,IBDCG,IBDFX,"C",0)) D TMP,CNTRL^VALM10(VALMCNT,1,26,IOINHI,IOINORM,0) Q
S IBDVAL=$O(^TMP("IBMF",$J,IBDCG,IBDFX,"D",0)) I IBDVAL S IBDVAL=^TMP("IBMF",$J,IBDCG,IBDFX,"D",IBDVAL) S X=$$SETSTR^VALM1(IBDVAL,X,28,26) I '$O(^TMP("IBMF",$J,IBDCG,IBDFX,"C",0)) D TMP,CNTRL^VALM10(VALMCNT,1,26,IOINHI,IOINORM,0)
S IBDVAL=$O(^TMP("IBMF",$J,IBDCG,IBDFX,"C",0)) I IBDVAL S IBDVAL=^TMP("IBMF",$J,IBDCG,IBDFX,"C",IBDVAL) S X=$$SETSTR^VALM1(IBDVAL,X,56,24) D TMP,CNTRL^VALM10(VALMCNT,1,26,IOINHI,IOINORM,0)
Q
;
;
TMP S ^TMP("IBDFCG",$J,IBDCNT,0)=X,^TMP("IBDFCG",$J,"IDX",VALMCNT,IBDCNT1)=""
S ^TMP("CGIDX",$J,IBDCNT1)=VALMCNT_"^"_IBDCG
Q
;
;
EDIT ; -- Edit a selected Clinic Group
N IBDVALM,VALMY
S VALMBCK=""
D EN^VALM2($G(XQORNOD(0))) G REP:'$O(VALMY(0)) S IBDVALM=0
D FULL^VALM1 S VALMBCK="R"
F IBDVALM=0:0 S IBDVALM=$O(VALMY(IBDVALM)) Q:'IBDVALM S DA=^TMP("CGIDX",$J,IBDVALM),DA=$P(DA,"^",2) D
.D MESS
.W !!,"Clinic Group: "_$P($G(^IBD(357.99,DA,0)),"^",1)
.S DIE="^IBD(357.99,",DA=DA,DR=".01;I $O(^IBD(357.99,DA,11,0)) S Y=""@99"";10;@99;I $O(^IBD(357.99,DA,10,0)) S Y=""@999"";11;@999" D ^DIE K DA,DIE,DR
D REP1 Q
;
DEL ; -- Delete Clinic Group
N IBDVALM,VALMY,DIR,DIRUT,DUOUT
S VALMBCK=""
D EN^VALM2($G(XQORNOD(0))) G REP:'$O(VALMY(0)) S IBDVALM=0
D FULL^VALM1 S VALMBCK="R"
F IBDVALM=0:0 S IBDVALM=$O(VALMY(IBDVALM)) Q:'IBDVALM S DA=^TMP("CGIDX",$J,IBDVALM),DA=$P(DA,"^",2) D
.I $O(^IBD(357.09,"ACG",DA,0)) W !!,"In use by parameter group, Not deleted",! D PAUSE^VALM1 Q
.W !!,"Clinic Group: "_$P($G(^IBD(357.99,DA,0)),"^",1)
.W ! S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are You Sure you want to delete "_$P($G(^IBD(357.99,DA,0)),"^",1)
.D ^DIR K DIR I Y'=1 W !,"Entry ",$P($G(^IBD(357.99,DA,0)),"^",1)," not Deleted!" Q
.D DP1
;
DELQ D INIT
S VALMBCK="R" Q
;
DP1 ; -- actual deletion
S DIK="^IBD(357.99," D ^DIK
W !,"Entry ",IBDVALM," Deleted"
Q
;
QE ; -- Quick edit Review entry
Q
;
MESS ; -- Message prior to editing a group
W !!,"Enter the clinics for this clinic group. Enter as many Clinics as you want."
W !,"If you want all clinics for a division, do not enter any clinics but enter"
W !,"the division name at the Select Division: prompt."
Q
;
ADD1 ; -- Add/Edit Clinic Group
N DLAYGO
D FULL^VALM1
D MESS
W ! S DIC("A")="Select GROUP NAME: ",DIC="^IBD(357.99,",DIC(0)="AELQMN",DIC("DR")=".01",DLAYGO=357.99 D ^DIC K DIC G:Y<1 REP1 S DA=+Y
S DIE="^IBD(357.99,",DA=DA,DR="I $O(^IBD(357.99,DA,11,0)) S Y=""@99"";10;I $O(^IBD(357.99,DA,10,0)) S Y=""@999"";11;@999" D ^DIE K DA,DIE,DR G ADD1
;
;
REP D INIT^IBDFPE S VALMBCK="R" Q
;
;
REP1 D INIT^IBDFCG S VALMBCK="R" 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="^IBD(357.99,",DIC(0)="QEZ" D ^DIC K DIC G:Y<0 JMP S Y=+Y D JUMP1 Q
JMP S DIC="^IBD(357.99,",DIC(0)="AEMN",DIC("A")="Select Clinic Group you wish to move to: " D ^DIC K DIC
I X["^" S VALMBG=1,VALMBCK="R" Q
JUMP1 I Y<0 G JUMP
N IBDFCAT
S IBDFCAT=$P(^IBD(357.99,+Y,0),"^",1)
I '$D(IBDFCG(IBDFCAT)) W !!,"There is no data listed for this Clinic Group" G JMP
S VALMBG=+IBDFCG(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
;
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
;
EXIT ; -- exit code
K IBDCLN,IBDCLN1,IBDFCG
K ^TMP("IBMF",$J)
Q
;
EXPND ; -- expand code
Q
;
NUL ; -- NULL MESSAGE
S ^TMP("IBDFCG",$J,1,0)=" ",^TMP("IBDFCG",$J,2,0)="There are no CLINIC GROUPS listed.",^TMP("CGIDX",$J,1)=1,^TMP("CGIDX",$J,2)=2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFCG 6156 printed Dec 13, 2024@02:52:05 Page 2
IBDFCG ;MAF/ALB - CLINIC GROUP FORMS SCREEN ; 09-FEB-1995
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
+3 ;
EN ; -- main entry point for IBDF EF CLINIC GROUP LT
+1 DO EN^VALM("IBDF EF CLINIC GROUP LT")
+2 QUIT
+3 ;
+4 ;
HDR ; -- header code
+1 SET VALMHDR(1)="This is a list of the Clinic Groups and the Clinics"
+2 SET VALMHDR(2)="and Divisions under them."
+3 QUIT
+4 ;
+5 ;
INIT ; -- init variables and list array
+1 NEW IBDFNODE,IBDFCL,IBDIFN,IBDFCGNM,IBDFCNUM,IBDCNT,IBDCNT1,IBDVAL,IBDVAL1,IBDFVAL,IBFASTXT,IBDCG,IBDCL,IBDDV,IBDFCFLG,IBDFCIEN,IBDFCN,IBDFDFLG,IBDFDIEN,IBDFGN,IBDFX,IBDVALM
+2 KILL IBDCLN1,IBDFCG
+3 SET (IBDCNT,IBFASTXT,IBDCNT1,VALMCNT)=0
+4 KILL ^TMP("IBMF",$JOB),^TMP("IBDFCG",$JOB),^TMP("CGIDX",$JOB),IBDCLN
DO KILL^VALM10()
+5 SET (IBDFGN,IBDFCGNM)=0
+6 FOR IBDFGN=0:0
SET IBDFCGNM=$ORDER(^IBD(357.99,"B",IBDFCGNM))
if IBDFCGNM']""
QUIT
FOR IBDIFN=0:0
SET IBDIFN=$ORDER(^IBD(357.99,"B",IBDFCGNM,IBDIFN))
if IBDIFN'>0
QUIT
IF IBDIFN]""
DO ARRAY
+7 SET (IBDFCG,IBDFCGNM)=0
+8 FOR IBDFCN=0:0
SET IBDFCGNM=$ORDER(IBDCLN1(IBDFCGNM))
if IBDFCGNM']""
QUIT
FOR IBDCG=0:0
SET IBDCG=$ORDER(IBDCLN1(IBDFCGNM,IBDCG))
if 'IBDCG
QUIT
IF $DATA(IBDCLN1(IBDFCGNM,IBDCG))
SET IBDCNT1=IBDCNT1+1
DO GROUPS
Begin DoDot:1
+9 FOR IBDFX=IBDFX:0
SET IBDFX=$ORDER(^TMP("IBMF",$JOB,IBDCG,IBDFX))
if 'IBDFX
QUIT
DO SETG1
+10 IF $ORDER(IBDCLN1(IBDFCGNM))]""
SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
SET X=""
SET X=$$SETSTR^VALM1(X,X,1,80)
DO TMP
End DoDot:1
+11 ;
+12 IF '$DATA(^TMP("IBDFCG",$JOB))
DO NUL
+13 QUIT
+14 ;
+15 ;
ARRAY ; -- Setting up array for clinic groups and the divisions and clinics
+1 SET IBDCLN1(IBDFCGNM,IBDIFN)=IBDIFN
+2 SET (IBDDV,IBDCL)=0
DO CLIN^IBDFCG1
DO DIV^IBDFCG1
+3 SET (IBDFX,IBDDV,IBDCL,IBDFCFLG,IBDFDFLG,IBDFCIEN,IBDFDIEN)=0
+4 FOR IBDFX=0:0
SET IBDFX=IBDFX+1
if 'IBDFCFLG
DO CLIN1^IBDFCG1
if 'IBDFDFLG
DO DIV1^IBDFCG1
if IBDFCFLG=1&(IBDFDFLG=1)
QUIT
+5 QUIT
+6 ;
+7 ;
SETG1 ; -- Creating the list entries
+1 SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+2 SET X=""
+3 SET IBDFVAL=$ORDER(^TMP("IBMF",$JOB,IBDCG,IBDFX,"D",0))
+4 SET IBDFVAL=$GET(^TMP("IBMF",$JOB,IBDCG,IBDFX,"D",+IBDFVAL))
SET X=$$SETSTR^VALM1(IBDFVAL,X,28,26)
+5 SET IBDFVAL=$ORDER(^TMP("IBMF",$JOB,IBDCG,IBDFX,"C",0))
+6 SET IBDFVAL=$GET(^TMP("IBMF",$JOB,IBDCG,IBDFX,"C",+IBDFVAL))
SET X=$$SETSTR^VALM1(IBDFVAL,X,56,23)
+7 DO TMP
+8 QUIT
+9 ;
+10 ;
GROUPS ; -- Creating the Listman Clinic Name titles for the list
+1 SET IBDCNT=IBDCNT+1
SET VALMCNT=VALMCNT+1
+2 SET IBDFCG(IBDFCGNM)=IBDCNT_"^"_IBDCG
+3 SET X=""
SET X=$$SETSTR^VALM1(IBDCNT1_" "_IBDFCGNM,X,1,26)
+4 SET IBDFX=1
+5 IF '$ORDER(^TMP("IBMF",$JOB,IBDCG,IBDFX,"D",0))
IF '$ORDER(^TMP("IBMF",$JOB,IBDCG,IBDFX,"C",0))
DO TMP
DO CNTRL^VALM10(VALMCNT,1,26,IOINHI,IOINORM,0)
QUIT
+6 SET IBDVAL=$ORDER(^TMP("IBMF",$JOB,IBDCG,IBDFX,"D",0))
IF IBDVAL
SET IBDVAL=^TMP("IBMF",$JOB,IBDCG,IBDFX,"D",IBDVAL)
SET X=$$SETSTR^VALM1(IBDVAL,X,28,26)
IF '$ORDER(^TMP("IBMF",$JOB,IBDCG,IBDFX,"C",0))
DO TMP
DO CNTRL^VALM10(VALMCNT,1,26,IOINHI,IOINORM,0)
+7 SET IBDVAL=$ORDER(^TMP("IBMF",$JOB,IBDCG,IBDFX,"C",0))
IF IBDVAL
SET IBDVAL=^TMP("IBMF",$JOB,IBDCG,IBDFX,"C",IBDVAL)
SET X=$$SETSTR^VALM1(IBDVAL,X,56,24)
DO TMP
DO CNTRL^VALM10(VALMCNT,1,26,IOINHI,IOINORM,0)
+8 QUIT
+9 ;
+10 ;
TMP SET ^TMP("IBDFCG",$JOB,IBDCNT,0)=X
SET ^TMP("IBDFCG",$JOB,"IDX",VALMCNT,IBDCNT1)=""
+1 SET ^TMP("CGIDX",$JOB,IBDCNT1)=VALMCNT_"^"_IBDCG
+2 QUIT
+3 ;
+4 ;
EDIT ; -- Edit a selected Clinic Group
+1 NEW IBDVALM,VALMY
+2 SET VALMBCK=""
+3 DO EN^VALM2($GET(XQORNOD(0)))
if '$ORDER(VALMY(0))
GOTO REP
SET IBDVALM=0
+4 DO FULL^VALM1
SET VALMBCK="R"
+5 FOR IBDVALM=0:0
SET IBDVALM=$ORDER(VALMY(IBDVALM))
if 'IBDVALM
QUIT
SET DA=^TMP("CGIDX",$JOB,IBDVALM)
SET DA=$PIECE(DA,"^",2)
Begin DoDot:1
+6 DO MESS
+7 WRITE !!,"Clinic Group: "_$PIECE($GET(^IBD(357.99,DA,0)),"^",1)
+8 SET DIE="^IBD(357.99,"
SET DA=DA
SET DR=".01;I $O(^IBD(357.99,DA,11,0)) S Y=""@99"";10;@99;I $O(^IBD(357.99,DA,10,0)) S Y=""@999"";11;@999"
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+9 DO REP1
QUIT
+10 ;
DEL ; -- Delete Clinic Group
+1 NEW IBDVALM,VALMY,DIR,DIRUT,DUOUT
+2 SET VALMBCK=""
+3 DO EN^VALM2($GET(XQORNOD(0)))
if '$ORDER(VALMY(0))
GOTO REP
SET IBDVALM=0
+4 DO FULL^VALM1
SET VALMBCK="R"
+5 FOR IBDVALM=0:0
SET IBDVALM=$ORDER(VALMY(IBDVALM))
if 'IBDVALM
QUIT
SET DA=^TMP("CGIDX",$JOB,IBDVALM)
SET DA=$PIECE(DA,"^",2)
Begin DoDot:1
+6 IF $ORDER(^IBD(357.09,"ACG",DA,0))
WRITE !!,"In use by parameter group, Not deleted",!
DO PAUSE^VALM1
QUIT
+7 WRITE !!,"Clinic Group: "_$PIECE($GET(^IBD(357.99,DA,0)),"^",1)
+8 WRITE !
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Are You Sure you want to delete "_$PIECE($GET(^IBD(357.99,DA,0)),"^",1)
+9 DO ^DIR
KILL DIR
IF Y'=1
WRITE !,"Entry ",$PIECE($GET(^IBD(357.99,DA,0)),"^",1)," not Deleted!"
QUIT
+10 DO DP1
End DoDot:1
+11 ;
DELQ DO INIT
+1 SET VALMBCK="R"
QUIT
+2 ;
DP1 ; -- actual deletion
+1 SET DIK="^IBD(357.99,"
DO ^DIK
+2 WRITE !,"Entry ",IBDVALM," Deleted"
+3 QUIT
+4 ;
QE ; -- Quick edit Review entry
+1 QUIT
+2 ;
MESS ; -- Message prior to editing a group
+1 WRITE !!,"Enter the clinics for this clinic group. Enter as many Clinics as you want."
+2 WRITE !,"If you want all clinics for a division, do not enter any clinics but enter"
+3 WRITE !,"the division name at the Select Division: prompt."
+4 QUIT
+5 ;
ADD1 ; -- Add/Edit Clinic Group
+1 NEW DLAYGO
+2 DO FULL^VALM1
+3 DO MESS
+4 WRITE !
SET DIC("A")="Select GROUP NAME: "
SET DIC="^IBD(357.99,"
SET DIC(0)="AELQMN"
SET DIC("DR")=".01"
SET DLAYGO=357.99
DO ^DIC
KILL DIC
if Y<1
GOTO REP1
SET DA=+Y
+5 SET DIE="^IBD(357.99,"
SET DA=DA
SET DR="I $O(^IBD(357.99,DA,11,0)) S Y=""@99"";10;I $O(^IBD(357.99,DA,10,0)) S Y=""@999"";11;@999"
DO ^DIE
KILL DA,DIE,DR
GOTO ADD1
+6 ;
+7 ;
REP DO INIT^IBDFPE
SET VALMBCK="R"
QUIT
+1 ;
+2 ;
REP1 DO INIT^IBDFCG
SET VALMBCK="R"
QUIT
+1 ;
+2 ;
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="^IBD(357.99,"
SET DIC(0)="QEZ"
DO ^DIC
KILL DIC
if Y<0
GOTO JMP
SET Y=+Y
DO JUMP1
QUIT
JMP SET DIC="^IBD(357.99,"
SET DIC(0)="AEMN"
SET DIC("A")="Select Clinic Group you wish to move to: "
DO ^DIC
KILL DIC
+1 IF X["^"
SET VALMBG=1
SET VALMBCK="R"
QUIT
JUMP1 IF Y<0
GOTO JUMP
+1 NEW IBDFCAT
+2 SET IBDFCAT=$PIECE(^IBD(357.99,+Y,0),"^",1)
+3 IF '$DATA(IBDFCG(IBDFCAT))
WRITE !!,"There is no data listed for this Clinic Group"
GOTO JMP
+4 SET VALMBG=+IBDFCG(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 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
+4 ;
EXIT ; -- exit code
+1 KILL IBDCLN,IBDCLN1,IBDFCG
+2 KILL ^TMP("IBMF",$JOB)
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
NUL ; -- NULL MESSAGE
+1 SET ^TMP("IBDFCG",$JOB,1,0)=" "
SET ^TMP("IBDFCG",$JOB,2,0)="There are no CLINIC GROUPS listed."
SET ^TMP("CGIDX",$JOB,1)=1
SET ^TMP("CGIDX",$JOB,2)=2
+2 QUIT
