IBDF14A ;ALB/CJM - AICS LIST CLINIC SETUP ; JUL 20,1993
;;3.0;AUTOMATED INFO COLLECTION SYS;**25**;APR 24, 1997
;
% ; -- entry point from ibdf14
I '$D(VAUTD) G ^IBDF14
D CLINICS,PRINT
Q
;
CLINICS ; -- get a list of clinics with setups defined
S CNT=0
S CLINIC="" F S CLINIC=$O(^SD(409.95,"B",CLINIC)) Q:'CLINIC D
.S SETUP=$O(^SD(409.95,"B",CLINIC,""))
.S NAME=$P($G(^SC(CLINIC,0)),"^")
.S DIVIS=$P($G(^SC(CLINIC,0)),"^",15)
.I DIVIS="" S DIVIS=$S(MULTI=0:$$PRIM^VASITE,MULTI=1:"Unknown",1:1)
.I 'VAUTD,'$D(VAUTD(DIVIS)) Q ;if not all divisions or select div.
.S:+DIVIS DIVIS=$P($G(^DG(40.8,+DIVIS,0)),"^")
.I DIVIS="" S DIVIS="Unknown"
.S:NAME]"" ^TMP($J,"IBCS",DIVIS,NAME)=CLINIC_"^"_SETUP,CNT(DIVIS)=$G(CNT(DIVIS))+1
Q
;
PRINT ; -- Main print driver for output
W:$E(IOST,1,2)="C-" @IOF
S NEWDIV=0
S DIVIS="" F S DIVIS=$O(^TMP($J,"IBCS",DIVIS)) Q:DIVIS=""!IBQUIT S NEWDIV=1 D
.S NAME="" F S NAME=$O(^TMP($J,"IBCS",DIVIS,NAME)) Q:NAME=""!IBQUIT S CLINIC=+^(NAME),SETUP=$P(^(NAME),"^",2) D Q:IBQUIT
..Q:'SETUP
..I $G(NEWDIV) D HEADER Q:IBQUIT W !?9,"Division: ",DIVIS,! S NEWDIV=0
..I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
..W !,"Clinic: ",NAME I '$$ACLN^IBDFCNOF(CLINIC) W " (Clinic Currently Inactive)"
..D FORMS Q:IBQUIT
..D REPORTS Q:IBQUIT
..D EXCLUDE Q:IBQUIT
..W !
.I 'VAUTD,$G(CNT(DIVIS))<1 D HEADER W !,"No clinics found for division '",DIVIS,"'",!
I $E(IOST,1,2)="C-",'IBQUIT D PAUSE
Q
;
FORMS ; -- prints the clinic's encounter forms to the report
S NODE=$G(^SD(409.95,SETUP,0))
I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
S FORM=$P(NODE,"^",2) I FORM W !,?5,"BASIC DEFAULT FORM: ..........................",$P($G(^IBE(357,FORM,0)),"^")
S FORM=$P(NODE,"^",5) I FORM W !,?5,"FORM WITH NO PRE-PRINTED PATIENT DATA: .......",$P($G(^IBE(357,FORM,0)),"^")
I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
S FORM=$P(NODE,"^",3) I FORM W !,?5,"SUPPLEMENTAL FORM - PATIENT WITH PRIOR VISITS: ",$P($G(^IBE(357,FORM,0)),"^")
I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
S FORM=$P(NODE,"^",4) I FORM W !,?5,"SUPPLEMENTAL FORM - FIRST TIME PATIENT: ......",$P($G(^IBE(357,FORM,0)),"^")
I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
S FORM=$P(NODE,"^",6) I FORM W !,?5,"SUPPLEMENTAL FORM - ALL PATIENTS: ............",$P($G(^IBE(357,FORM,0)),"^")
I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
S FORM=$P(NODE,"^",8) I FORM W !,?5,"SUPPLEMENTAL FORM - ALL PATIENTS: ............",$P($G(^IBE(357,FORM,0)),"^")
I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
S FORM=$P(NODE,"^",9) I FORM W !,?5,"SUPPLEMENTAL FORM - ALL PATIENTS: ............",$P($G(^IBE(357,FORM,0)),"^")
I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
S FORM=$P(NODE,"^",7) I FORM W !,?5,"RESERVED FOR FUTURE USE: .....................",$P($G(^IBE(357,FORM,0)),"^")
Q
;
REPORTS ; -- prints the clinic's reports
Q:'$O(^SD(409.95,SETUP,1,0))
I ($Y>(IOSL-5)) D HEADER Q:IBQUIT
W !!,?5,"REPORTS",?50,"PRINT CONDITION",!,?5,"=======",?50,"==============="
S REPORT=0 F S REPORT=$O(^SD(409.95,SETUP,1,REPORT)) Q:'REPORT D Q:IBQUIT
.I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
.S NODE=$G(^SD(409.95,SETUP,1,REPORT,0))
.S INTRFACE=$P(NODE,"^"),COND=$P(NODE,"^",2)
.I INTRFACE,COND S INTRFACE=$P($G(^IBE(357.6,INTRFACE,0)),"^"),COND=$P($G(^IBE(357.92,COND,0)),"^") W:INTRFACE]"" !,?5,INTRFACE,?50,COND
Q
;
EXCLUDE ; -- prints the division reports excluded from clinic
Q:'$O(^SD(409.95,SETUP,2,0))
I ($Y>(IOSL-5)) D HEADER Q:IBQUIT
W !!,?5,"EXCLUDED REPORTS",!,?5,"================"
S REPORT=0 F S REPORT=$O(^SD(409.95,SETUP,2,REPORT)) Q:'REPORT D Q:IBQUIT
.I ($Y>(IOSL-3)) D HEADER Q:IBQUIT
.S NODE=$G(^SD(409.95,SETUP,2,REPORT,0))
.S INTRFACE=$P(NODE,"^")
.I INTRFACE S INTRFACE=$P($G(^IBE(357.6,INTRFACE,0)),"^") W:INTRFACE]"" !,?5,INTRFACE
Q
;
I $E(IOST,1,2)="C-",$Y>1,PAGE>1 D PAUSE Q:IBQUIT
I PAGE>1 W @IOF
W !,"AICS Print Manager Clinic Setup Report",?IOM-32,IBHDT," PAGE ",PAGE
W !,"For Division: ",DIVIS
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF14A 4148 printed Oct 16, 2024@18:51:30 Page 2
IBDF14A ;ALB/CJM - AICS LIST CLINIC SETUP ; JUL 20,1993
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**25**;APR 24, 1997
+2 ;
% ; -- entry point from ibdf14
+1 IF '$DATA(VAUTD)
GOTO ^IBDF14
+2 DO CLINICS
DO PRINT
+3 QUIT
+4 ;
CLINICS ; -- get a list of clinics with setups defined
+1 SET CNT=0
+2 SET CLINIC=""
FOR
SET CLINIC=$ORDER(^SD(409.95,"B",CLINIC))
if 'CLINIC
QUIT
Begin DoDot:1
+3 SET SETUP=$ORDER(^SD(409.95,"B",CLINIC,""))
+4 SET NAME=$PIECE($GET(^SC(CLINIC,0)),"^")
+5 SET DIVIS=$PIECE($GET(^SC(CLINIC,0)),"^",15)
+6 IF DIVIS=""
SET DIVIS=$SELECT(MULTI=0:$$PRIM^VASITE,MULTI=1:"Unknown",1:1)
+7 ;if not all divisions or select div.
IF 'VAUTD
IF '$DATA(VAUTD(DIVIS))
QUIT
+8 if +DIVIS
SET DIVIS=$PIECE($GET(^DG(40.8,+DIVIS,0)),"^")
+9 IF DIVIS=""
SET DIVIS="Unknown"
+10 if NAME]""
SET ^TMP($JOB,"IBCS",DIVIS,NAME)=CLINIC_"^"_SETUP
SET CNT(DIVIS)=$GET(CNT(DIVIS))+1
End DoDot:1
+11 QUIT
+12 ;
PRINT ; -- Main print driver for output
+1 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+2 SET NEWDIV=0
+3 SET DIVIS=""
FOR
SET DIVIS=$ORDER(^TMP($JOB,"IBCS",DIVIS))
if DIVIS=""!IBQUIT
QUIT
SET NEWDIV=1
Begin DoDot:1
+4 SET NAME=""
FOR
SET NAME=$ORDER(^TMP($JOB,"IBCS",DIVIS,NAME))
if NAME=""!IBQUIT
QUIT
SET CLINIC=+^(NAME)
SET SETUP=$PIECE(^(NAME),"^",2)
Begin DoDot:2
+5 if 'SETUP
QUIT
+6 IF $GET(NEWDIV)
DO HEADER
if IBQUIT
QUIT
WRITE !?9,"Division: ",DIVIS,!
SET NEWDIV=0
+7 IF ($Y>(IOSL-3))
DO HEADER
if IBQUIT
QUIT
+8 WRITE !,"Clinic: ",NAME
IF '$$ACLN^IBDFCNOF(CLINIC)
WRITE " (Clinic Currently Inactive)"
+9 DO FORMS
if IBQUIT
QUIT
+10 DO REPORTS
if IBQUIT
QUIT
+11 DO EXCLUDE
if IBQUIT
QUIT
+12 WRITE !
End DoDot:2
if IBQUIT
QUIT
+13 IF 'VAUTD
IF $GET(CNT(DIVIS))<1
DO HEADER
WRITE !,"No clinics found for division '",DIVIS,"'",!
End DoDot:1
+14 IF $EXTRACT(IOST,1,2)="C-"
IF 'IBQUIT
DO PAUSE
+15 QUIT
+16 ;
FORMS ; -- prints the clinic's encounter forms to the report
+1 SET NODE=$GET(^SD(409.95,SETUP,0))
+2 IF ($Y>(IOSL-3))
DO HEADER
if IBQUIT
QUIT
+3 SET FORM=$PIECE(NODE,"^",2)
IF FORM
WRITE !,?5,"BASIC DEFAULT FORM: ..........................",$PIECE($GET(^IBE(357,FORM,0)),"^")
+4 SET FORM=$PIECE(NODE,"^",5)
IF FORM
WRITE !,?5,"FORM WITH NO PRE-PRINTED PATIENT DATA: .......",$PIECE($GET(^IBE(357,FORM,0)),"^")
+5 IF ($Y>(IOSL-3))
DO HEADER
if IBQUIT
QUIT
+6 SET FORM=$PIECE(NODE,"^",3)
IF FORM
WRITE !,?5,"SUPPLEMENTAL FORM - PATIENT WITH PRIOR VISITS: ",$PIECE($GET(^IBE(357,FORM,0)),"^")
+7 IF ($Y>(IOSL-3))
DO HEADER
if IBQUIT
QUIT
+8 SET FORM=$PIECE(NODE,"^",4)
IF FORM
WRITE !,?5,"SUPPLEMENTAL FORM - FIRST TIME PATIENT: ......",$PIECE($GET(^IBE(357,FORM,0)),"^")
+9 IF ($Y>(IOSL-3))
DO HEADER
if IBQUIT
QUIT
+10 SET FORM=$PIECE(NODE,"^",6)
IF FORM
WRITE !,?5,"SUPPLEMENTAL FORM - ALL PATIENTS: ............",$PIECE($GET(^IBE(357,FORM,0)),"^")
+11 IF ($Y>(IOSL-3))
DO HEADER
if IBQUIT
QUIT
+12 SET FORM=$PIECE(NODE,"^",8)
IF FORM
WRITE !,?5,"SUPPLEMENTAL FORM - ALL PATIENTS: ............",$PIECE($GET(^IBE(357,FORM,0)),"^")
+13 IF ($Y>(IOSL-3))
DO HEADER
if IBQUIT
QUIT
+14 SET FORM=$PIECE(NODE,"^",9)
IF FORM
WRITE !,?5,"SUPPLEMENTAL FORM - ALL PATIENTS: ............",$PIECE($GET(^IBE(357,FORM,0)),"^")
+15 IF ($Y>(IOSL-3))
DO HEADER
if IBQUIT
QUIT
+16 SET FORM=$PIECE(NODE,"^",7)
IF FORM
WRITE !,?5,"RESERVED FOR FUTURE USE: .....................",$PIECE($GET(^IBE(357,FORM,0)),"^")
+17 QUIT
+18 ;
REPORTS ; -- prints the clinic's reports
+1 if '$ORDER(^SD(409.95,SETUP,1,0))
QUIT
+2 IF ($Y>(IOSL-5))
DO HEADER
if IBQUIT
QUIT
+3 WRITE !!,?5,"REPORTS",?50,"PRINT CONDITION",!,?5,"=======",?50,"==============="
+4 SET REPORT=0
FOR
SET REPORT=$ORDER(^SD(409.95,SETUP,1,REPORT))
if 'REPORT
QUIT
Begin DoDot:1
+5 IF ($Y>(IOSL-3))
DO HEADER
if IBQUIT
QUIT
+6 SET NODE=$GET(^SD(409.95,SETUP,1,REPORT,0))
+7 SET INTRFACE=$PIECE(NODE,"^")
SET COND=$PIECE(NODE,"^",2)
+8 IF INTRFACE
IF COND
SET INTRFACE=$PIECE($GET(^IBE(357.6,INTRFACE,0)),"^")
SET COND=$PIECE($GET(^IBE(357.92,COND,0)),"^")
if INTRFACE]""
WRITE !,?5,INTRFACE,?50,COND
End DoDot:1
if IBQUIT
QUIT
+9 QUIT
+10 ;
EXCLUDE ; -- prints the division reports excluded from clinic
+1 if '$ORDER(^SD(409.95,SETUP,2,0))
QUIT
+2 IF ($Y>(IOSL-5))
DO HEADER
if IBQUIT
QUIT
+3 WRITE !!,?5,"EXCLUDED REPORTS",!,?5,"================"
+4 SET REPORT=0
FOR
SET REPORT=$ORDER(^SD(409.95,SETUP,2,REPORT))
if 'REPORT
QUIT
Begin DoDot:1
+5 IF ($Y>(IOSL-3))
DO HEADER
if IBQUIT
QUIT
+6 SET NODE=$GET(^SD(409.95,SETUP,2,REPORT,0))
+7 SET INTRFACE=$PIECE(NODE,"^")
+8 IF INTRFACE
SET INTRFACE=$PIECE($GET(^IBE(357.6,INTRFACE,0)),"^")
if INTRFACE]""
WRITE !,?5,INTRFACE
End DoDot:1
if IBQUIT
QUIT
+9 QUIT
+10 ;
+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 !,"AICS Print Manager Clinic Setup Report",?IOM-32,IBHDT," PAGE ",PAGE
+4 WRITE !,"For Division: ",DIVIS
+5 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
+6 SET PAGE=PAGE+1
+7 QUIT
+8 ;
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
