Routine: IBDF1B

IBDF1B ;ALB/CJM - ENCOUNTER FORM (printing forms for appointments); 3/1/93

 ;;3.0;AUTOMATED INFO COLLECTION SYS;**29**;APR 24, 1997

 ;IBSRT=1 for sort by clinic/patient name

 ;IBSRT=2 for sort by terminal digits

 ;IBSRT=3 for sort by clinic/terminal digits

 ;SELECTBY="P" if user wants to select appts by patient

 ;SELECTBY="C" if user wants to select appts by division/clinic

 ;IBDT=date for appointments

 ;IBREPRNT'="" if this is a reprint of a previous job - then it's either equal to clinic name or 1st 4 terminal digits

 ;IBSTRTDV is the division to start from in the case of a reprint

 ;IBADDONS=1 if user wants to do add-ons only, 0 otherwise

EN ;

 N IBREPRNT,SELECTBY,IBDT,IBSRT,IBADDONS,IBSTRTDV,QUIT,X

 S (IBSTRTDV,IBREPRNT)="",(QUIT,IBADDONS)=0

 ;set the error trap so workspace in ^TMP is erased in case of abnormal termination of the print job

 S X="ERRORTRP^IBDF1B",@^%ZOSF("TRAP")

 K ^TMP("IBDF",$J),^TMP("IB",$J)

 D HOME^%ZIS

 .D SELECTBY Q:QUIT  S:SELECTBY="P" IBSRT=1 ;if selecting by patient then sort by clinic/patient rather than by terminal digits

 .D:SELECTBY="C" SORTBY^IBDF1BA Q:QUIT

 .D APPTDATE Q:QUIT

 .;now allow user to makes selections, whether by patient or clinic

 .D @SELECTBY

.;

 .;if nothing selected exit

 .Q:'$D(^TMP("IBDF",$J))

.;

 .;since selecting by entire clinics, may want to do add-ons only or restart the job

 .I SELECTBY="C" D  Q:QUIT

 ..D ADDONS Q:QUIT

 ..D REPRINT Q:QUIT

 ;if nothing selected exit

END G:('$D(^TMP("IBDF",$J)))!QUIT EXIT

 W !,$C(7),"** Encounter Forms require a page size of 80 lines and 132 columns. **"

 K %IS,%ZIS,IOP S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS G:POP EXIT

 I $D(IO("Q")) S ZTRTN="^IBDF1B1",ZTDESC="IBDF Encounter Forms",ZTSAVE("^TMP(""IBDF"",$J,")="",ZTSAVE("IB*")="" D ^%ZTLOAD K IO("Q") W !,$S($D(ZTSK):"Request Queued Task="_ZTSK,1:"Request Canceled") D HOME^%ZIS G EXIT

 U IO

 D ^IBDF1B1

EXIT ;

 K ^TMP("IBDF",$J),^TMP("IB",$J),^TMP("RPT",$J),^TMP("DFN",$J)

 I $D(ZTQUEUED) S ZTREQ="@" Q

 K DTOUT,DUOUT,DIRUT,DIROUT,X,Y,D0,DA,IBTYPE

 D ^%ZISC

REPRINT ;for prior job that partially completed?

 ;IBSTRTDV is the division to restart from

 ;IBREPRNT is the clinic or first 4 of terminal digits to restart from

 S DIR(0)="Y",DIR("A")="IS THIS A REPRINT OF A PREVIOUS RUN"

 S DIR("B")="NO",DIR("?")="ANSWER YES IF SOME OF THE FORMS WERE ALREADY PRINTED BY A PREVIOUS JOB THAT DID NOT SUCCESSFULLY COMPLETE"

 D ^DIR K DIR I $D(DIRUT)!(Y=-1) S QUIT=1 Q

 I Y D  I IBREPRNT="" S QUIT=1 Q

 .I IBSRT=2 D  ;sorting by division/terminal digit

 ..;ask which division to restart from

 ..S IBSTRTDV=$$STARTDIV^IBDF1BA I IBSTRTDV="" S IBREPRNT="" Q

 ..;ask which terminal digit to restart from

 ..D TERMSTRT^IBDF1BA Q:IBREPRNT=""

 .I (IBSRT=1)!(IBSRT=3) D CLNCSTRT^IBDF1BA ;sorting by division/clinic, ask which clinic to restart from

ADDONS ;add-ons only?

 S DIR(0)="Y",DIR("A")="WANT TO PRINT ADD-ONS ONLY"

 S DIR("B")="NO",DIR("?")="ANSWER YES TO ONLY PRINT ADD-ONS"

 D ^DIR K DIR I $D(DIRUT)!(Y=-1) S QUIT=1 Q

 S IBADDONS=Y

SELECTBY ;select by patient or clinic?

 W !,"Do you want to print forms for a particular patient or for entire clinics?",!

 K DIR S DIR("B")="Clinic",DIR(0)="SO^P:Patient;C:Clinic",DIR("A")="Select Appointment by"

 D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q

 S SELECTBY=Y

P ;print by patient - get patient then appointment(s) for date

 N IBTMP,IBNM,DFN

 ;IBNM=patient name, IBTMP=array to store patient's appts

 F  K DIC S DIC="^DPT(",DIC(0)="AEQM" D ^DIC K DIC Q:Y<0  S DFN=+Y,IBNM=$P(Y,"^",2) D SEARCH^IBDF1BA,DISP^IBDF1BA

C ;print all appointments for a clinic - find division then clinic, print all/some clinics for all/some divisions

 N GROUPS,IEN

 ;get the PRINT MANAGER CLINIC GROUPS

 S GROUPS=""

 K DIR

 S DIR(0)="PAO^357.99:AEMQ",DIR("A")="Select Print Manager Clinic Group:",DIR("?")="You can choose from previously defined clinic groups."

 F  D ^DIR Q:((+Y<0)!$D(DIRUT))  S GROUPS(+Y)="",DIR("A")="Select another Print Manager Clinic Group:"

 S GROUPS=0 F  S GROUPS=$O(GROUPS(GROUPS)) Q:'GROUPS  D

 .S IEN=0 F  S IEN=$O(^IBD(357.99,GROUPS,10,IEN)) Q:'IEN  S IBCLN=+$G(^IBD(357.99,GROUPS,10,IEN,0)) S:IBCLN ^TMP("IBDF",$J,"C",IBCLN)=""

 .S IEN=0 F  S IEN=$O(^IBD(357.99,GROUPS,11,IEN)) Q:'IEN  S IBDIV=+$G(^IBD(357.99,GROUPS,11,IEN,0)) S:IBDIV ^TMP("IBDF",$J,"D",IBDIV)=""

 K DIR

 G:$O(GROUPS(0)) ENDC

 ;now ask divisions and clinics

 W !!,"Now you can select individual divisions and clinics."

 ;D ASK2^IBODIV G:$D(VAUTD)<11&(VAUTD=0) ENDC

 S VAUTD=1 I $P($G(^DG(43,1,"GL")),"^",2) D DIVISION^VAUTOMA I Y=-1 G ENDC

 S DIC("S")="I $P(^SC(+Y,0),U,3)=""C"",$S(VAUTD:1,$D(VAUTD(+$P(^(0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD($O(^DG(40.8,0)))):1,1:0)"

 W !!,"If you want to print forms for all clinics in the divisions you have",!,"chosen (for those clinics with forms defined) then select ALL."

 W !!,"Otherwise, select the particular clinics you want.",!

 S DIC="^SC(",VAUTVB="VAUTC",VAUTNI=2,VAUTSTR="clinic" D FIRST^VAUTOMA K DIC G:$D(VAUTC)<11&(VAUTC=0) ENDC

 I VAUTC,VAUTD S ^TMP("IBDF",$J,"D","ALL")=""

 I VAUTC,'VAUTD S IBDIV="" F  S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV=""  S ^TMP("IBDF",$J,"D",IBDIV)=""

 I 'VAUTC S IBCLN="" F  S IBCLN=$O(VAUTC(IBCLN)) Q:IBCLN=""  S ^TMP("IBDF",$J,"C",IBCLN)=""

ENDC K VAUTNI,VAUTD,VAUTC,VAUTVB,VAUTSTR,IBDIV,IBCLN,DIC

APPTDATE ;print forms for appointments on what date?

 K DIR S DIR(0)="D^::AEX",DIR("B")="TODAY",DIR("A")="Appointment Date to Print Forms For"

 S DIR("?",1)="Only Clinics and Patients with Appointments on this Date will be allowed."

 S DIR("?")="Nothing will print for Appointments in Clinics/Divisions with no forms defined."

 D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q

 S IBDT=Y

ERRORTRP ;the error trap

 K ^TMP("IBDF",$J),^TMP("IB",$J)

 D @^%ZOSF("ERRTN")

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF1B   5914     printed  Feb 19, 2025@00:17:28                                                                                                                                                                                                      Page 2

IBDF1B    ;ALB/CJM - ENCOUNTER FORM (printing forms for appointments); 3/1/93

 +1       ;;3.0;AUTOMATED INFO COLLECTION SYS;**29**;APR 24, 1997

 +2       ;

 +3       ;IBSRT=1 for sort by clinic/patient name

 +4       ;IBSRT=2 for sort by terminal digits

 +5       ;IBSRT=3 for sort by clinic/terminal digits

 +6       ;

 +7       ;SELECTBY="P" if user wants to select appts by patient

 +8       ;SELECTBY="C" if user wants to select appts by division/clinic

 +9       ;

 +10      ;IBDT=date for appointments

 +11      ;IBREPRNT'="" if this is a reprint of a previous job - then it's either equal to clinic name or 1st 4 terminal digits

 +12      ;IBSTRTDV is the division to start from in the case of a reprint

 +13      ;IBADDONS=1 if user wants to do add-ons only, 0 otherwise

 +14      ;

EN        ;

 +1        NEW IBREPRNT,SELECTBY,IBDT,IBSRT,IBADDONS,IBSTRTDV,QUIT,X

 +2        SET (IBSTRTDV,IBREPRNT)=""

           SET (QUIT,IBADDONS)=0

 +3       ;

 +4       ;set the error trap so workspace in ^TMP is erased in case of abnormal termination of the print job

 +5        SET X="ERRORTRP^IBDF1B"

           SET @^%ZOSF("TRAP")

 +6       ;

 +7        KILL ^TMP("IBDF",$JOB),^TMP("IB",$JOB)

 +8        DO HOME^%ZIS

 +9        Begin DoDot:1

 +10      ;if selecting by patient then sort by clinic/patient rather than by terminal digits

               DO SELECTBY

               if QUIT

                   QUIT

               if SELECTBY="P"

                   SET IBSRT=1

 +11           if SELECTBY="C"

                   DO SORTBY^IBDF1BA

               if QUIT

                   QUIT

 +12           DO APPTDATE

               if QUIT

                   QUIT

 +13      ;now allow user to makes selections, whether by patient or clinic

 +14           DO @SELECTBY

 +15      ;

 +16      ;if nothing selected exit

 +17           if '$DATA(^TMP("IBDF",$JOB))

                   QUIT

 +18      ;

 +19      ;since selecting by entire clinics, may want to do add-ons only or restart the job

 +20           IF SELECTBY="C"

                   Begin DoDot:2

 +21                   DO ADDONS

                       if QUIT

                           QUIT

 +22                   DO REPRINT

                       if QUIT

                           QUIT

                   End DoDot:2

                   if QUIT

                       QUIT

           End DoDot:1

 +23      ;

 +24      ;

 +25      ;if nothing selected exit

END        if ('$DATA(^TMP("IBDF",$JOB)))!QUIT

               GOTO EXIT

 +1        WRITE !,$CHAR(7),"** Encounter Forms require a page size of 80 lines and 132 columns. **"

 +2        KILL %IS,%ZIS,IOP

           SET %ZIS="QM"

           SET %ZIS("A")="OUTPUT DEVICE: "

           DO ^%ZIS

           if POP

               GOTO EXIT

 +3        IF $DATA(IO("Q"))

               SET ZTRTN="^IBDF1B1"

               SET ZTDESC="IBDF Encounter Forms"

               SET ZTSAVE("^TMP(""IBDF"",$J,")=""

               SET ZTSAVE("IB*")=""

               DO ^%ZTLOAD

               KILL IO("Q")

               WRITE !,$SELECT($DATA(ZTSK):"Request Queued Task="_ZTSK,1:"Request Canceled")

               DO HOME^%ZIS

               GOTO EXIT

 +4        USE IO

 +5        DO ^IBDF1B1

EXIT      ;

 +1        KILL ^TMP("IBDF",$JOB),^TMP("IB",$JOB),^TMP("RPT",$JOB),^TMP("DFN",$JOB)

 +2        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

               QUIT

 +3        KILL DTOUT,DUOUT,DIRUT,DIROUT,X,Y,D0,DA,IBTYPE

 +4        DO ^%ZISC

 +5        QUIT

 +6       ;

REPRINT   ;for prior job that partially completed?

 +1       ;IBSTRTDV is the division to restart from

 +2       ;IBREPRNT is the clinic or first 4 of terminal digits to restart from

 +3        SET DIR(0)="Y"

           SET DIR("A")="IS THIS A REPRINT OF A PREVIOUS RUN"

 +4        SET DIR("B")="NO"

           SET DIR("?")="ANSWER YES IF SOME OF THE FORMS WERE ALREADY PRINTED BY A PREVIOUS JOB THAT DID NOT SUCCESSFULLY COMPLETE"

 +5        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)!(Y=-1)

               SET QUIT=1

               QUIT

 +6        IF Y

               Begin DoDot:1

 +7       ;sorting by division/terminal digit

                   IF IBSRT=2

                       Begin DoDot:2

 +8       ;ask which division to restart from

 +9                        SET IBSTRTDV=$$STARTDIV^IBDF1BA

                           IF IBSTRTDV=""

                               SET IBREPRNT=""

                               QUIT

 +10      ;ask which terminal digit to restart from

 +11                       DO TERMSTRT^IBDF1BA

                           if IBREPRNT=""

                               QUIT

                       End DoDot:2

 +12      ;sorting by division/clinic, ask which clinic to restart from

                   IF (IBSRT=1)!(IBSRT=3)

                       DO CLNCSTRT^IBDF1BA

               End DoDot:1

               IF IBREPRNT=""

                   SET QUIT=1

                   QUIT

 +13       QUIT

ADDONS    ;add-ons only?

 +1        SET DIR(0)="Y"

           SET DIR("A")="WANT TO PRINT ADD-ONS ONLY"

 +2        SET DIR("B")="NO"

           SET DIR("?")="ANSWER YES TO ONLY PRINT ADD-ONS"

 +3        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)!(Y=-1)

               SET QUIT=1

               QUIT

 +4        SET IBADDONS=Y

 +5        QUIT

SELECTBY  ;select by patient or clinic?

 +1        WRITE !,"Do you want to print forms for a particular patient or for entire clinics?",!

 +2        KILL DIR

           SET DIR("B")="Clinic"

           SET DIR(0)="SO^P:Patient;C:Clinic"

           SET DIR("A")="Select Appointment by"

 +3        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               SET QUIT=1

               QUIT

 +4        SET SELECTBY=Y

 +5        QUIT

 +6       ;

P         ;print by patient - get patient then appointment(s) for date

 +1        NEW IBTMP,IBNM,DFN

 +2       ;IBNM=patient name, IBTMP=array to store patient's appts

 +3        FOR

               KILL DIC

               SET DIC="^DPT("

               SET DIC(0)="AEQM"

               DO ^DIC

               KILL DIC

               if Y<0

                   QUIT

               SET DFN=+Y

               SET IBNM=$PIECE(Y,"^",2)

               DO SEARCH^IBDF1BA

               DO DISP^IBDF1BA

 +4        QUIT

 +5       ;

C         ;print all appointments for a clinic - find division then clinic, print all/some clinics for all/some divisions

 +1       ;

 +2        NEW GROUPS,IEN

 +3       ;

 +4       ;get the PRINT MANAGER CLINIC GROUPS

 +5        SET GROUPS=""

 +6        KILL DIR

 +7        SET DIR(0)="PAO^357.99:AEMQ"

           SET DIR("A")="Select Print Manager Clinic Group:"

           SET DIR("?")="You can choose from previously defined clinic groups."

 +8        FOR

               DO ^DIR

               if ((+Y<0)!$DATA(DIRUT))

                   QUIT

               SET GROUPS(+Y)=""

               SET DIR("A")="Select another Print Manager Clinic Group:"

 +9        SET GROUPS=0

FOR

               SET GROUPS=$ORDER(GROUPS(GROUPS))

               if 'GROUPS

                   QUIT

               Begin DoDot:1

 +10               SET IEN=0

FOR

                       SET IEN=$ORDER(^IBD(357.99,GROUPS,10,IEN))

                       if 'IEN

                           QUIT

                       SET IBCLN=+$GET(^IBD(357.99,GROUPS,10,IEN,0))

                       if IBCLN

                           SET ^TMP("IBDF",$JOB,"C",IBCLN)=""

 +11               SET IEN=0

FOR

                       SET IEN=$ORDER(^IBD(357.99,GROUPS,11,IEN))

                       if 'IEN

                           QUIT

                       SET IBDIV=+$GET(^IBD(357.99,GROUPS,11,IEN,0))

                       if IBDIV

                           SET ^TMP("IBDF",$JOB,"D",IBDIV)=""

               End DoDot:1

 +12       KILL DIR

 +13       if $ORDER(GROUPS(0))

               GOTO ENDC

 +14      ;

 +15      ;now ask divisions and clinics

 +16       WRITE !!,"Now you can select individual divisions and clinics."

 +17      ;D ASK2^IBODIV G:$D(VAUTD)<11&(VAUTD=0) ENDC

 +18       SET VAUTD=1

           IF $PIECE($GET(^DG(43,1,"GL")),"^",2)

               DO DIVISION^VAUTOMA

               IF Y=-1

                   GOTO ENDC

 +19       SET DIC("S")="I $P(^SC(+Y,0),U,3)=""C"",$S(VAUTD:1,$D(VAUTD(+$P(^(0),U,15))):1,'+$P(^(0),U,15)&$D(VAUTD($O(^DG(40.8,0)))):1,1:0)"

 +20       WRITE !!,"If you want to print forms for all clinics in the divisions you have",!,"chosen (for those clinics with forms defined) then select ALL."

 +21       WRITE !!,"Otherwise, select the particular clinics you want.",!

 +22       SET DIC="^SC("

           SET VAUTVB="VAUTC"

           SET VAUTNI=2

           SET VAUTSTR="clinic"

           DO FIRST^VAUTOMA

           KILL DIC

           if $DATA(VAUTC)<11&(VAUTC=0)

               GOTO ENDC

 +23       IF VAUTC

               IF VAUTD

                   SET ^TMP("IBDF",$JOB,"D","ALL")=""

 +24       IF VAUTC

               IF 'VAUTD

                   SET IBDIV=""

FOR

                       SET IBDIV=$ORDER(VAUTD(IBDIV))

                       if IBDIV=""

                           QUIT

                       SET ^TMP("IBDF",$JOB,"D",IBDIV)=""

 +25       IF 'VAUTC

               SET IBCLN=""

FOR

                   SET IBCLN=$ORDER(VAUTC(IBCLN))

                   if IBCLN=""

                       QUIT

                   SET ^TMP("IBDF",$JOB,"C",IBCLN)=""

ENDC       KILL VAUTNI,VAUTD,VAUTC,VAUTVB,VAUTSTR,IBDIV,IBCLN,DIC

 +1        QUIT

 +2       ;

APPTDATE  ;print forms for appointments on what date?

 +1        KILL DIR

           SET DIR(0)="D^::AEX"

           SET DIR("B")="TODAY"

           SET DIR("A")="Appointment Date to Print Forms For"

 +2        SET DIR("?",1)="Only Clinics and Patients with Appointments on this Date will be allowed."

 +3        SET DIR("?")="Nothing will print for Appointments in Clinics/Divisions with no forms defined."

 +4        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               SET QUIT=1

               QUIT

 +5        SET IBDT=Y

 +6        QUIT

 +7       ;

ERRORTRP  ;the error trap

 +1        KILL ^TMP("IBDF",$JOB),^TMP("IB",$JOB)

 +2        DO @^%ZOSF("ERRTN")

 +3        QUIT

IBDF1B.m