IBDF15A ;ALB/CJM - AICS FORM USE BY DIVISION/CLINIC ; JUL 20,1993
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
; -- prints for each encounter form the clinics using it
;
PRINT ; -- Main print driver
W:$E(IOST,1,2)="C-" @IOF
S FORMNAM="" F S FORMNAM=$O(^IBE(357,"B",FORMNAM)) Q:FORMNAM="" S FORM=$O(^IBE(357,"B",FORMNAM,0)) Q:'FORM D Q:IBQUIT
.Q:$P($G(^IBE(357,FORM,0)),"^",7) ;exclude toolkit forms
.D CLINIC(FORM,FORMNAM)
D LIST
I $E(IOST,1,2)="C-",'IBQUIT D PAUSE
Q
;
CLINIC(FORM,FORMNAM) ;
; -- finds the list of clinics using FORM
; ^TMP($J,"IBDCS",0) is number of clinics found
; ^TMP($J,"IBDCS",divname, div pointer, form name, form pointer,
; clinic name)=clinic pointer := is list of clinics
;
N CLINIC,SETUP,IDX,CLNAME,DIVIS,DIVNAM,CNT
F IDX="C","D","E","F","G","H","I","J" D
.S SETUP="" F S SETUP=$O(^SD(409.95,IDX,FORM,SETUP)) Q:'SETUP D
..S CLINIC=$P($G(^SD(409.95,SETUP,0)),"^",1)
..Q:'CLINIC
..S CLNAME=$P($G(^SC(CLINIC,0)),"^",1)
..Q:CLNAME=""
..S DIVIS=$P($G(^SC(CLINIC,0)),"^",15)
..I DIVIS="" S DIVIS=$S(MULTI=0:$$PRIM^VASITE,1:"Unknown")
..S DIVNAM=$P($G(^DG(40.8,+DIVIS,0)),"^")
..S:DIVNAM="" DIVNAM="Unknown"
..S CNT=$G(CNT)+1
..S ^TMP($J,"IBDCS",DIVNAM,+$G(DIVIS),FORMNAM,FORM,CLNAME)=CLINIC_"^"_IDX
..S ^TMP($J,"IBDCS",DIVNAM,+$G(DIVIS))=$G(^TMP($J,"IBDCS",DIVNAM,+$G(DIVIS)))+1
S:$G(CNT)<1 ^TMP($J,"IBDCN",FORMNAM,FORM)="" ;forms not in use
Q
;
LIST ; -- lists the clinics using FORM
N DIVNAM,DIVIS,FORMNAM,FORM,CLNAME,CLINIC,NEWDIV,IBDONE,IDX
;
; -- list forms not in use
S DIVNAM="",NEWDIV=0
F S DIVNAM=$O(^TMP($J,"IBDCS",DIVNAM)) Q:DIVNAM=""!(IBQUIT) S DIVIS=+$O(^TMP($J,"IBDCS",DIVNAM,"")) I VAUTD=1!($D(VAUTD(DIVIS))) D
.;
.S NEWDIV=1
.K IBDONE
.S FORMNAM=""
.F S FORMNAM=$O(^TMP($J,"IBDCS",DIVNAM,DIVIS,FORMNAM)) Q:FORMNAM=""!(IBQUIT) S FORM=$O(^TMP($J,"IBDCS",DIVNAM,DIVIS,FORMNAM,0)) D
..;
..S CLNAME=""
..F S CLNAME=$O(^TMP($J,"IBDCS",DIVNAM,DIVIS,FORMNAM,FORM,CLNAME)) Q:CLNAME=""!(IBQUIT) S CLINIC=+^(CLNAME),IDX=$P(^(CLNAME),"^",2) I '$D(IBDONE(FORM)) W ! D LINEONE,ALL(FORMNAM,CLNAME,DIVNAM)
;
; -- list forms not in use
S FORMNAM="",NEWDIV=1,DIVNAM="FORMS NOT IN USE"
F S FORMNAM=$O(^TMP($J,"IBDCN",FORMNAM)) Q:FORMNAM=""!(IBQUIT) S FORM=$O(^TMP($J,"IBDCN",FORMNAM,0)) D LINETWO
Q
;
LINEONE ; -- print on report header, lines, etc.
;
I NEWDIV D HEADER Q:IBQUIT W !,?10,"Division: ",DIVNAM S NEWDIV=0
I $Y>(IOSL-3) D HEADER Q:IBQUIT
W !,FORMNAM,?32,$E(CLNAME,1,25),?59,$E(DIVNAM,1,20),?81,$$TYPE(IDX)
I '$$ACLN^IBDFCNOF(CLINIC) W ?100," (Clinic Currently Inactive)"
S IBDONE(FORM)=""
Q
;
LINETWO ; -- print lines for forms not in use
I NEWDIV D HEADER Q:IBQUIT S NEWDIV=0
I $Y>(IOSL-3) D HEADER Q:IBQUIT
W !,FORMNAM,?32,"** NOT IN USE **"
Q
;
LINETHR ; -- print lines for clinics in other divisions
I $Y>(IOSL-3) D HEADER Q:IBQUIT
W !,?32,CLNAME,?59,$E(DIVNAM,1,20),?81,$$TYPE(IDX)
I '$$ACLN^IBDFCNOF(CLINIC) W ?100," (Clinic Currently Inactive)"
Q
;
ALL(FORMNAM,CL1,DV1) ;
; -- find all clinics using for irregardless of division
; stored in ^TMP($J,"IBDCS",DIVNAM,DIVIS,FORMNAM,FORM,CLNAME)
;
N FORM,CLNAME,DIVNAM,DIVIS
S DIVNAM=""
F S DIVNAM=$O(^TMP($J,"IBDCS",DIVNAM)) Q:DIVNAM=""!(IBQUIT) S DIVIS=+$O(^TMP($J,"IBDCS",DIVNAM,"")) I VAUTD=1!($D(VAUTD(DIVIS))) D
.S FORM=+$O(^TMP($J,"IBDCS",DIVNAM,DIVIS,FORMNAM,0))
.S CLNAME="" F S CLNAME=$O(^TMP($J,"IBDCS",DIVNAM,DIVIS,FORMNAM,FORM,CLNAME)) Q:CLNAME=""!(IBQUIT) S CLINIC=+^(CLNAME) D
..Q:CL1=CLNAME&(DV1=DIVNAM)
..D LINETHR
Q
;
;S FORM=$O(^TMP($J,"IBDCL",FORMNAM,0))
;S CLNAME="" F S CLNAME=$O(^TMP($J,"IBDCL",FORMNAM,FORM,CLNAME)) Q:CLNAME=""!(IBQUIT) D
;.S DIVNAM="" F S DIVNAM=$O(^TMP($J,"IBDCL",FORMNAM,FORM,CLNAME,DIVNAM)) Q:DIVNAM=""!(IBQUIT) D
;..Q:CL1=CLNAME&(DV1=DIVNAM)
;..D LINETHR
Q
;
I $E(IOST,1,2)="C-",$Y>1,PAGE>1 D PAUSE Q:IBQUIT
I PAGE>1 W @IOF
W !,"List of Encounter Forms and their Use by Clinics",?IOM-30,IBHDT," PAGE ",PAGE
W !,"For Division: ",$G(DIVNAM)
W !,"FORM NAME",?32,"CLINIC",?59,"DIVISION",?81,"FORM USAGE"
W !,$TR($J(" ",IOM)," ","-")
S PAGE=PAGE+1
Q
;
PAUSE ; -- hold screen
N DIR,X,Y
F Q:$Y>(IOSL-2) W !
S DIR(0)="E" D ^DIR S IBQUIT=$S(+Y:0,1:1)
Q
;
TYPE(IDX) ;
; -- type of form
; input cross reference from print Manager Clinic Setups (409.95)
; output name of type of form
; IDX="C","D","E","F","G","H","I","J"
;
N X
S IDX=$E(IDX,1)
S X="" I IDX="" G TYPEQ
S X=$S(IDX="C":"Basic Form",IDX="D":"Supplmntl form - Establshed Pt.",IDX="E":"Supplmntl Form - First Visit",IDX="F":"Form w/o Patient Data",IDX="G":"Supplmntl Form #1",1:"")
I X="" S X=$S(IDX="H":"Reserved",IDX="I":"Supplmntl Form #2",IDX="J":"Supplmntl Form #3",1:"")
TYPEQ Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF15A 4916 printed Apr 09, 2024@21:31:53 Page 2
IBDF15A ;ALB/CJM - AICS FORM USE BY DIVISION/CLINIC ; JUL 20,1993
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
+3 ; -- prints for each encounter form the clinics using it
+4 ;
PRINT ; -- Main print driver
+1 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+2 SET FORMNAM=""
FOR
SET FORMNAM=$ORDER(^IBE(357,"B",FORMNAM))
if FORMNAM=""
QUIT
SET FORM=$ORDER(^IBE(357,"B",FORMNAM,0))
if 'FORM
QUIT
Begin DoDot:1
+3 ;exclude toolkit forms
if $PIECE($GET(^IBE(357,FORM,0)),"^",7)
QUIT
+4 DO CLINIC(FORM,FORMNAM)
End DoDot:1
if IBQUIT
QUIT
+5 DO LIST
+6 IF $EXTRACT(IOST,1,2)="C-"
IF 'IBQUIT
DO PAUSE
+7 QUIT
+8 ;
CLINIC(FORM,FORMNAM) ;
+1 ; -- finds the list of clinics using FORM
+2 ; ^TMP($J,"IBDCS",0) is number of clinics found
+3 ; ^TMP($J,"IBDCS",divname, div pointer, form name, form pointer,
+4 ; clinic name)=clinic pointer := is list of clinics
+5 ;
+6 NEW CLINIC,SETUP,IDX,CLNAME,DIVIS,DIVNAM,CNT
+7 FOR IDX="C","D","E","F","G","H","I","J"
Begin DoDot:1
+8 SET SETUP=""
FOR
SET SETUP=$ORDER(^SD(409.95,IDX,FORM,SETUP))
if 'SETUP
QUIT
Begin DoDot:2
+9 SET CLINIC=$PIECE($GET(^SD(409.95,SETUP,0)),"^",1)
+10 if 'CLINIC
QUIT
+11 SET CLNAME=$PIECE($GET(^SC(CLINIC,0)),"^",1)
+12 if CLNAME=""
QUIT
+13 SET DIVIS=$PIECE($GET(^SC(CLINIC,0)),"^",15)
+14 IF DIVIS=""
SET DIVIS=$SELECT(MULTI=0:$$PRIM^VASITE,1:"Unknown")
+15 SET DIVNAM=$PIECE($GET(^DG(40.8,+DIVIS,0)),"^")
+16 if DIVNAM=""
SET DIVNAM="Unknown"
+17 SET CNT=$GET(CNT)+1
+18 SET ^TMP($JOB,"IBDCS",DIVNAM,+$GET(DIVIS),FORMNAM,FORM,CLNAME)=CLINIC_"^"_IDX
+19 SET ^TMP($JOB,"IBDCS",DIVNAM,+$GET(DIVIS))=$GET(^TMP($JOB,"IBDCS",DIVNAM,+$GET(DIVIS)))+1
End DoDot:2
End DoDot:1
+20 ;forms not in use
if $GET(CNT)<1
SET ^TMP($JOB,"IBDCN",FORMNAM,FORM)=""
+21 QUIT
+22 ;
LIST ; -- lists the clinics using FORM
+1 NEW DIVNAM,DIVIS,FORMNAM,FORM,CLNAME,CLINIC,NEWDIV,IBDONE,IDX
+2 ;
+3 ; -- list forms not in use
+4 SET DIVNAM=""
SET NEWDIV=0
+5 FOR
SET DIVNAM=$ORDER(^TMP($JOB,"IBDCS",DIVNAM))
if DIVNAM=""!(IBQUIT)
QUIT
SET DIVIS=+$ORDER(^TMP($JOB,"IBDCS",DIVNAM,""))
IF VAUTD=1!($DATA(VAUTD(DIVIS)))
Begin DoDot:1
+6 ;
+7 SET NEWDIV=1
+8 KILL IBDONE
+9 SET FORMNAM=""
+10 FOR
SET FORMNAM=$ORDER(^TMP($JOB,"IBDCS",DIVNAM,DIVIS,FORMNAM))
if FORMNAM=""!(IBQUIT)
QUIT
SET FORM=$ORDER(^TMP($JOB,"IBDCS",DIVNAM,DIVIS,FORMNAM,0))
Begin DoDot:2
+11 ;
+12 SET CLNAME=""
+13 FOR
SET CLNAME=$ORDER(^TMP($JOB,"IBDCS",DIVNAM,DIVIS,FORMNAM,FORM,CLNAME))
if CLNAME=""!(IBQUIT)
QUIT
SET CLINIC=+^(CLNAME)
SET IDX=$PIECE(^(CLNAME),"^",2)
IF '$DATA(IBDONE(FORM))
WRITE !
DO LINEONE
DO ALL(FORMNAM,CLNAME,DIVNAM)
End DoDot:2
End DoDot:1
+14 ;
+15 ; -- list forms not in use
+16 SET FORMNAM=""
SET NEWDIV=1
SET DIVNAM="FORMS NOT IN USE"
+17 FOR
SET FORMNAM=$ORDER(^TMP($JOB,"IBDCN",FORMNAM))
if FORMNAM=""!(IBQUIT)
QUIT
SET FORM=$ORDER(^TMP($JOB,"IBDCN",FORMNAM,0))
DO LINETWO
+18 QUIT
+19 ;
LINEONE ; -- print on report header, lines, etc.
+1 ;
+2 IF NEWDIV
DO HEADER
if IBQUIT
QUIT
WRITE !,?10,"Division: ",DIVNAM
SET NEWDIV=0
+3 IF $Y>(IOSL-3)
DO HEADER
if IBQUIT
QUIT
+4 WRITE !,FORMNAM,?32,$EXTRACT(CLNAME,1,25),?59,$EXTRACT(DIVNAM,1,20),?81,$$TYPE(IDX)
+5 IF '$$ACLN^IBDFCNOF(CLINIC)
WRITE ?100," (Clinic Currently Inactive)"
+6 SET IBDONE(FORM)=""
+7 QUIT
+8 ;
LINETWO ; -- print lines for forms not in use
+1 IF NEWDIV
DO HEADER
if IBQUIT
QUIT
SET NEWDIV=0
+2 IF $Y>(IOSL-3)
DO HEADER
if IBQUIT
QUIT
+3 WRITE !,FORMNAM,?32,"** NOT IN USE **"
+4 QUIT
+5 ;
LINETHR ; -- print lines for clinics in other divisions
+1 IF $Y>(IOSL-3)
DO HEADER
if IBQUIT
QUIT
+2 WRITE !,?32,CLNAME,?59,$EXTRACT(DIVNAM,1,20),?81,$$TYPE(IDX)
+3 IF '$$ACLN^IBDFCNOF(CLINIC)
WRITE ?100," (Clinic Currently Inactive)"
+4 QUIT
+5 ;
ALL(FORMNAM,CL1,DV1) ;
+1 ; -- find all clinics using for irregardless of division
+2 ; stored in ^TMP($J,"IBDCS",DIVNAM,DIVIS,FORMNAM,FORM,CLNAME)
+3 ;
+4 NEW FORM,CLNAME,DIVNAM,DIVIS
+5 SET DIVNAM=""
+6 FOR
SET DIVNAM=$ORDER(^TMP($JOB,"IBDCS",DIVNAM))
if DIVNAM=""!(IBQUIT)
QUIT
SET DIVIS=+$ORDER(^TMP($JOB,"IBDCS",DIVNAM,""))
IF VAUTD=1!($DATA(VAUTD(DIVIS)))
Begin DoDot:1
+7 SET FORM=+$ORDER(^TMP($JOB,"IBDCS",DIVNAM,DIVIS,FORMNAM,0))
+8 SET CLNAME=""
FOR
SET CLNAME=$ORDER(^TMP($JOB,"IBDCS",DIVNAM,DIVIS,FORMNAM,FORM,CLNAME))
if CLNAME=""!(IBQUIT)
QUIT
SET CLINIC=+^(CLNAME)
Begin DoDot:2
+9 if CL1=CLNAME&(DV1=DIVNAM)
QUIT
+10 DO LINETHR
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
+13 ;S FORM=$O(^TMP($J,"IBDCL",FORMNAM,0))
+14 ;S CLNAME="" F S CLNAME=$O(^TMP($J,"IBDCL",FORMNAM,FORM,CLNAME)) Q:CLNAME=""!(IBQUIT) D
+15 ;.S DIVNAM="" F S DIVNAM=$O(^TMP($J,"IBDCL",FORMNAM,FORM,CLNAME,DIVNAM)) Q:DIVNAM=""!(IBQUIT) D
+16 ;..Q:CL1=CLNAME&(DV1=DIVNAM)
+17 ;..D LINETHR
+18 QUIT
+19 ;
+1 IF $EXTRACT(IOST,1,2)="C-"
IF $Y>1
IF PAGE>1
DO PAUSE
if IBQUIT
QUIT
+2 IF PAGE>1
WRITE @IOF
+3 WRITE !,"List of Encounter Forms and their Use by Clinics",?IOM-30,IBHDT," PAGE ",PAGE
+4 WRITE !,"For Division: ",$GET(DIVNAM)
+5 WRITE !,"FORM NAME",?32,"CLINIC",?59,"DIVISION",?81,"FORM USAGE"
+6 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
+7 SET PAGE=PAGE+1
+8 QUIT
+9 ;
PAUSE ; -- hold screen
+1 NEW DIR,X,Y
+2 FOR
if $Y>(IOSL-2)
QUIT
WRITE !
+3 SET DIR(0)="E"
DO ^DIR
SET IBQUIT=$SELECT(+Y:0,1:1)
+4 QUIT
+5 ;
TYPE(IDX) ;
+1 ; -- type of form
+2 ; input cross reference from print Manager Clinic Setups (409.95)
+3 ; output name of type of form
+4 ; IDX="C","D","E","F","G","H","I","J"
+5 ;
+6 NEW X
+7 SET IDX=$EXTRACT(IDX,1)
+8 SET X=""
IF IDX=""
GOTO TYPEQ
+9 SET X=$SELECT(IDX="C":"Basic Form",IDX="D":"Supplmntl form - Establshed Pt.",IDX="E":"Supplmntl Form - First Visit",IDX="F":"Form w/o Patient Data",IDX="G":"Supplmntl Form #1",1:"")
+10 IF X=""
SET X=$SELECT(IDX="H":"Reserved",IDX="I":"Supplmntl Form #2",IDX="J":"Supplmntl Form #3",1:"")
TYPEQ QUIT X
