- 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 Mar 13, 2025@21:55:47 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
