Routine: IBDFDE6

IBDFDE6 ;ALB/AAS - AICS Manual Data Entry, Entry point by clinic ; 29-APR-96

 ;;3.0;AUTOMATED INFO COLLECTION SYS;**11,51**;APR 24, 1997

 W !,?4,"** This option is OUT OF ORDER **" QUIT   ;Code set Versioning

% N %,%H,C,I,J,X,Y,ADD,DEL,ASKOTHER,DIR,DIC,DA,CNT,DFN,DIRUT,DUOUT,DTOUT,POP,RTN,FRMDATA,IBY,IBQUIT,IBDF,IBDOBJ,IBDPTSTI,IBDPTSTE,IBDPTNM,IBDPTDTI,SEL,IBD,IBDCKOUT

 N IBDPTDTE,IBDFMNME,IBDFMIEN,IBDFMSTI,IBDFMSTE,IBDFMIDI,IBDCLNME,IBFORM,IBDCLNPH,IBDPID,IBDPTPRI,IBDSEL,IBDPI,IBDCO,PXCA,SDCLST,PXCASTAT,PXKNODA,PXKNODB,IBDREDIT,IBDASK,IBDPRE,IBDX,ANS,CLNAME,CLSETUP,IBDSC,FORM,FORMLST,IBDFDT,IBD

 I '$D(DT) D DT^DICRW

 D HOME^%ZIS

 W !!,"Data Entry of Encounter Forms (by Clinic)",!!

STRT ; -- ask for Clinic, date then patient.

 ;    Only list patients w/no data entry

 ;    find all forms for appt., then go through 1 at a time

 D END

 S IBQUIT=0

 S (IBDSC,IBDF("CLINIC"))=$$SELCL G:IBQUIT STRTQ

 I IBDSC<1 S IBQUIT=1 G STRTQ

 S CLNAME=$P($G(^SC(+IBDSC,0)),"^")

 S CLSETUP=$G(^SD(409.95,+$O(^SD(409.95,"B",+IBDSC,0)),0))

APPT W ! S IBDFDT=$$SELAP(.IBDF) G:IBQUIT STRTQ

 I IBDFDT<0 W !! G STRT

 D BLD

 I '$D(^TMP("IBD-PL",$J,IBDF("CLINIC"))) W !!,"No appointments on that Date!",!! G APPT

OVER D HDR ;,LIST

 W !! D SELPT G:IBQUIT STRTQ

 S IBDF("OPTION")=1

 I $G(RESULT)="" G APPT

 I $G(RESULT)=-1 G OVERQ

 S (DFN,IBDF("DFN"))=+RESULT,IBDF("APPT")=$P(RESULT,"^",2)

 S FORMLST=$$FINDID^IBDF18C(DFN,IBDF("APPT"),"",1)

 I FORMLST]"" I IBDF("CLINIC")'=$P(^IBD(357.96,+FORMLST,0),"^",10) S FORMLST=""

 I FORMLST="" W !,"No forms Printed for Patient" D ANYWAY I IBQUIT G STRTQ

 I FORMLST="" G OVERQ ;D PAUSE^IBDFDE G OVERQ

 F IBDX=1:1 S IBDF("FORM")=$P(FORMLST,"^",IBDX) Q:IBDF("FORM")=""  I IBDF("FORM")'="" D EN^IBDFDE K IBDSEL,IBDPI Q:IBQUIT

 W !!

 ;S IBDF("CLINIC")=IBDSC

OVERQ G OVER

STRTQ ;D PAUSE^IBDFDE

 G:IBQUIT END

 G APPT

ANYWAY ; -- if no forms available ask if want to enter form anyway

 ;    all to use default form, clinic setup,or any form

 N X,Y,DIR,DIRUT

 S DIR("?")="If you wish to enter data for this patient anyway, chose whether to use the default form, select any form, or use the clinic setup.  Answer None if you don't wish to enter any data."

 S DIR("A")="Enter Data from [A]ny form, [C]linic Setup, [D]efault, [N]one: "

 S DIR(0)="SA^A:ANYFORM;C:CLINIC SETUP;D:DEFAULT;N:NONE",DIR("B")="CLINIC SETUP"

 I '$D(CLSETUP),+$G(IBDF("CLINIC")) S CLNAME=$P($G(^SC(+IBDF("CLINIC"),0)),"^"),CLSETUP=$G(^SD(409.95,+$O(^SD(409.95,"B",+IBDF("CLINIC"),0)),0))

 I CLSETUP="" S DIR("B")="DEFAULT" W !,"No Forms Defined for Clinic"

 D ^DIR K DIR

 I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 G ANYWAYQ

 I $D(DIRUT) G ANYWAYQ

 S ANS=Y

 I ANS="N" G ANYWAYQ

 I ANS="D" D  G ANYWAYQ

 .S IBFORM=$P($G(^IBD(357.09,1,0)),"^",4)

 .I IBFORM="" S IBFORM=$O(^IBE(357,"B","PRIMARY CARE SAMPLE V2.1",0))

 .S FORMLST=$$OTHFRM(IBFORM)

.Q

 I ANS="A" D  G ANYWAYQ

 .S DIC("S")="I $P(^(0),U)'=""GARBAGE"",$P(^(0),U)'=""TOOL KIT"""

 .S DIC="^IBE(357,",DIC(0)="AEQM" D ^DIC K DIC Q:+Y<1

 .S IBFORM=+Y

 .S FORMLST=$$OTHFRM(IBFORM)

.Q

 I ANS="C" D  G ANYWAYQ

 .F IBD=2,6,8,9,3,4 S IBFORM=$P(CLSETUP,"^",IBD) I IBFORM W ! S FORMLST=FORMLST_$$OTHFRM(IBFORM)_"^"

 .I FORMLST="" W !!,"No forms defined for clinic"

.Q

ANYWAYQ Q

OTHFRM(IBFORM) ; -- if no form printed, add form tracking entry,

 ; -- compile form if necessary return form list

 N FORMID,FORMLST

 S FORMID=$P($G(^IBE(357,IBFORM,0)),"^",13)

 I FORMID="" D

 .W !,"Please wait, Creating the necessary entry..."

 .L +^IBE(357,IBFORM):1

 .S FORMID=$$FORMTYPE^IBDF18D(1) W "."

 .S $P(^IBD(357.95,FORMID,0),"^",21)=IBFORM W "."

 .S $P(^IBE(357,IBFORM,0),"^",13)=FORMID

 .S:$P(^IBE(357,IBFORM,0),"^",13) ^IBE(357,"ADEF",$P(^IBE(357,IBFORM,0),"^",13),IBFORM)=""

 .L -^IBE(357,IBFORM)

 S FORMLST=+$$FID^IBDF18C(DFN,IBDF("APPT"),1,FORMID,IBDF("CLINIC"))

 S DIE="^IBD(357.96,",DR=".11////20",DA=FORMLST D ^DIE K DA,DR,DIC,DIE

 Q FORMLST

SELCL() ; -- select clinic

 S IBQUIT=0

 N DIR,DA,DR,DIC,DIE,X,Y,ANS,DIRUT

 S ANS=-1

 S DIR("?")="Enter the name of the clinic that you are entering encounter forms for."

 S DIR("S")="I $P(^(0),U,3)=""C"""

 S DIR(0)="PO^44:AEQM",DIR("A")="Select Clinic" D ^DIR K DIR,DA,DR,DIC

 I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 G SELCLQ

 I $D(DIRUT) G SELCLQ

 S ANS=+Y

SELCLQ Q ANS

SELAP(IBDF) ; -- select appointment date for a clinic

 S IBQUIT=0

 N DIR,DA,DR,DIC,DIE,X,Y,ANS,DIRUT

 S ANS=-1

 ;I $G(LASTDATE)?7N S DIR("B")=$$FMTE^XLFDT(LASTDATE)

 ;R !,"Appointment Date: ",X:$G(DTIME)

 S DIR(0)="DO^:DT:EX",DIR("A")="Appointment Date"

 S DIR("?")="Enter the date for the clinic that you wish to enter encounter forms for"

 S DIR("??")="^D APDT^IBDFDE6"

 D ^DIR K DIR

 I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 G SELAPQ

 I $D(DIRUT) G SELAPQ

 S ANS=+Y

SELAPQ Q ANS

SELPT ; -- select patient(s) to process

 S IBDCLIN=IBDF("CLINIC") N ARRAY,CNT,IBD K IBDF,IBDCO,PXCA,SEL S IBDF("CLINIC")=IBDCLIN K IBDCLIN

 S (ARRAY,RESULT,ANS)="",(IBQUIT,CNT)=0

 S DIR("?")="Enter the listed number or the name of the patient or the last 4 number of the SSN or the first letter of the last name with the last 4 numbers of the SSN."

 S DIR("??")="^D LIST^IBDFDE6"

 S DIR(0)="FO^1:30",DIR("A")="Select Patient"

 D ^DIR K DIR

 I $D(DUOUT)!($D(DTOUT)) S IBQUIT=1 G SELQ

 S ANS=$$UP^XLFSTR(Y)

 I ANS="" G SELQ

 I $D(DIRUT) S IBQUIT=1 G SELQ

 I ANS=+ANS S ARRAY="IBD-PL" I $D(^TMP(ARRAY,$J,IBDF("CLINIC"),ANS)) S RESULT=^(ANS) W "   ",$P($G(^DPT(+RESULT,0)),"^") G SELQ

 I ANS?4N S ARRAY="IBD-PL4" D ARRAY(ARRAY,ANS) G FIND

 I ANS?1A4N S ARRAY="IBD-PLB" D ARRAY(ARRAY,ANS) G FIND

 S ARRAY="IBD-PLN" D ARRAY(ARRAY,ANS) D  G FIND

 .S NAME=ANS F  S NAME=$O(^TMP(ARRAY,$J,IBDF("CLINIC"),NAME)) Q:$E(NAME,1,$L(ANS))'=ANS  D ARRAY(ARRAY,NAME)

 G SELQ

FIND ;find appropriate pt appt from array

 I CNT=1 S RESULT=$G(^TMP(ARRAY,$J,IBDF("CLINIC"),$P(IBD(CNT),"^",2),+IBD(CNT))) D:$D(RESULT)  G SELQ

 .I ARRAY="IBD-PLN" W "   ",$E($P($G(^DPT(+RESULT,0)),"^"),($L(ANS)+1),999) Q

 .W "   ",$P($G(^DPT(+RESULT,0)),"^")

 S RESULT=$$MULT^IBDFDE61(CNT,.IBD) D:$D(RESULT)

 .W "   ",$P($G(^DPT(+RESULT,0)),"^")

 I RESULT="" W $C(7),"  ??  Not Found" S RESULT=-1

SELQ Q

ARRAY(ARRAY,ANS) ; -- bld array of multiple patients

 ; -- required variables:  array = name x-ref; ans = name of selection

 S A=0 F  S A=$O(^TMP(ARRAY,$J,IBDF("CLINIC"),ANS,A)) Q:'A  S CNT=CNT+1,IBD(CNT)=A_"^"_ANS

BLD ; -- Find all appointments for a date

 K ^TMP("IBD-PL",$J),^TMP("IBD-PLN",$J)

 N SC,IBD,IBD1,NODE,SNODE

 S IBD=IBDFDT,SC=IBDF("CLINIC"),CNT=0

 F  S IBD=$O(^SC(SC,"S",IBD)) Q:'IBD!(IBD>(IBDFDT+.24))  D

 .S IBD1=0 F  S IBD1=$O(^SC(SC,"S",IBD,1,IBD1)) Q:'IBD1  D

 ..S NODE=$G(^SC(SC,"S",IBD,1,IBD1,0))

 ..S SNODE=$G(^DPT(+NODE,"S",IBD,0))

 ..S X=$P(SNODE,"^",2)

 ..I X'="","CNAPCA"[X Q  ;inpatient appointments are okay

 ..S (DFN,IBDF("DFN"))=+NODE

 ..S CNT=CNT+1

 ..S ^TMP("IBD-PL",$J,SC,CNT)=DFN_"^"_IBD_"^"_SNODE

 ..S ^TMP("IBD-PLN",$J,SC,$P(^DPT(DFN,0),"^"),CNT)=DFN_"^"_IBD_"^"_SNODE

 ..S ^TMP("IBD-PLB",$J,SC,$E($P(^DPT(DFN,0),"^",1),1)_$E($P(^DPT(DFN,0),"^",9),6,9),CNT)=DFN_"^"_IBD_"^"_SNODE

 ..S ^TMP("IBD-PL4",$J,SC,$E($P(^DPT(DFN,0),"^",9),6,9),CNT)=DFN_"^"_IBD_"^"_SNODE

LIST ; -- print list of patients

 N IBD,IBJ,FORM,STATUS,CNT,X,IBQUIT

 S IBQUIT=0

 S IBD=0 F  S IBD=$O(^TMP("IBD-PL",$J,IBDF("CLINIC"),IBD)) Q:'IBD!(IBQUIT)  S NODE=$G(^TMP("IBD-PL",$J,IBDF("CLINIC"),IBD)) D ONE(NODE,IBD) I '(IBD#15) D ASKPT^IBDFDE61(IBD)

ONE(NODE,IBD1) ; -- write one line

 N CNT,C

 Q:$G(NODE)=""

 S DFN=+NODE,APPT=$P(NODE,"^",2)

 S FORM=$$FINDID^IBDF18C(DFN,APPT,"",1),STATUS="NO FORM PRINTED"

 S CNT=0 F IBJ=1:1 S X=$P(FORM,"^",IBJ) Q:X=""  S CNT=CNT+1

 I +FORM S Y=$P($G(^IBD(357.96,+FORM,0)),"^",11),C=$P(^DD(357.96,.11,0),"^",2) D Y^DIQ S STATUS=Y

 W !?2,IBD1,?5,$E($P(^DPT(DFN,0),"^"),1,18),?26,$P($G(^DPT(DFN,.36)),"^",4),?32,$$FMTE^XLFDT(+APPT),?52,$E($G(STATUS),1,24),?77,"("_CNT_")"

APDT ; -- list last 30 days appointment dates in clinic

 S (X,Y)=$$FMADD^XLFDT(DT,-62),CNT=0

 F  S X=$O(^SC(IBDF("CLINIC"),"S",X)) Q:'X!(X>DT)  D

 .I $E(X,1,7)=Y Q

 .S Y=$E(X,1,7),CNT=CNT+1

 .I CNT=1 W !!,"The following are valid Appointment dates in the past 60 days:"

 .W:(CNT#4=1) !,?3,$$FMTE^XLFDT(Y)

 .W:(CNT#4=2) ?20,$$FMTE^XLFDT(Y)

 .W:(CNT#4=3) ?40,$$FMTE^XLFDT(Y)

 .W:(CNT#4=0) ?60,$$FMTE^XLFDT(Y)

HDR ; -- print Clinic header

 N CNT,IBD,IBD1 W @IOF

 S CNT=0

 F IBD=2,6,8,9,3,4 S IBD1=$P(CLSETUP,"^",IBD) I IBD1 S CNT=CNT+1

 W !,"      Clinic: ",$E(CLNAME,1,25) W ?40,"         Date: ",$$FMTE^XLFDT(IBDFDT)

 S FORM=$P(CLSETUP,"^",2),IBDFMNME=$P($G(^IBE(357,+FORM,0)),"^")

 W !,"  Basic Form: ",$E(IBDFMNME,1,25) W ?40," Active Forms: ",CNT

 W !,"Appointments: ",$O(^TMP("IBD-PL",$J,IBDF("CLINIC"),""),-1)

 W !,$TR($J(" ",IOM)," ","=")

END K I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF

 K ^TMP("IBD-PL",$J),^TMP("IBD-PLN",$J),^TMP("IBD-PLB",$J),^TMP("IBD-PL4",$J),^TMP("IBD-MORE",$J),^TMP("IBD-PLCHK",$J)

 K ^TMP("IBD-ASK",$J),^TMP("IBD-LCODE",$J),^TMP("IBD-LST",$J),^TMP("IBD-LTEXT",$J),^TMP("IBD-OBJ",$J)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFDE6   9270     printed  Mar 13, 2025@21:57:26                                                                                                                                                                                                     Page 2

IBDFDE6   ;ALB/AAS - AICS Manual Data Entry, Entry point by clinic ; 29-APR-96

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

 +2       ;

 +3       ;Code set Versioning

           WRITE !,?4,"** This option is OUT OF ORDER **"

           QUIT

 +4       ;

%          NEW %,%H,C,I,J,X,Y,ADD,DEL,ASKOTHER,DIR,DIC,DA,CNT,DFN,DIRUT,DUOUT,DTOUT,POP,RTN,FRMDATA,IBY,IBQUIT,IBDF,IBDOBJ,IBDPTSTI,IBDPTSTE,IBDPTNM,IBDPTDTI,SEL,IBD,IBDCKOUT

 +1        NEW IBDPTDTE,IBDFMNME,IBDFMIEN,IBDFMSTI,IBDFMSTE,IBDFMIDI,IBDCLNME,IBFORM,IBDCLNPH,IBDPID,IBDPTPRI,IBDSEL,IBDPI,IBDCO,PXCA,SDCLST,PXCASTAT,PXKNODA,PXKNODB,IBDREDIT,IBDASK,IBDPRE,IBDX,ANS,CLNAME,CLSETUP,IBDSC,FORM,FORMLST,IBDFDT,IBD

 +2       ;

 +3        IF '$DATA(DT)

               DO DT^DICRW

 +4        DO HOME^%ZIS

 +5        WRITE !!,"Data Entry of Encounter Forms (by Clinic)",!!

 +6       ;

STRT      ; -- ask for Clinic, date then patient.

 +1       ;    Only list patients w/no data entry

 +2       ;    find all forms for appt., then go through 1 at a time

 +3       ;

 +4        DO END

 +5        SET IBQUIT=0

 +6        SET (IBDSC,IBDF("CLINIC"))=$$SELCL

           if IBQUIT

               GOTO STRTQ

 +7        IF IBDSC<1

               SET IBQUIT=1

               GOTO STRTQ

 +8        SET CLNAME=$PIECE($GET(^SC(+IBDSC,0)),"^")

 +9        SET CLSETUP=$GET(^SD(409.95,+$ORDER(^SD(409.95,"B",+IBDSC,0)),0))

 +10      ;

APPT       WRITE !

           SET IBDFDT=$$SELAP(.IBDF)

           if IBQUIT

               GOTO STRTQ

 +1        IF IBDFDT<0

               WRITE !!

               GOTO STRT

 +2       ;

 +3        DO BLD

 +4        IF '$DATA(^TMP("IBD-PL",$JOB,IBDF("CLINIC")))

               WRITE !!,"No appointments on that Date!",!!

               GOTO APPT

 +5       ;

OVER      ;,LIST

           DO HDR

 +1        WRITE !!

           DO SELPT

           if IBQUIT

               GOTO STRTQ

 +2        SET IBDF("OPTION")=1

 +3        IF $GET(RESULT)=""

               GOTO APPT

 +4        IF $GET(RESULT)=-1

               GOTO OVERQ

 +5        SET (DFN,IBDF("DFN"))=+RESULT

           SET IBDF("APPT")=$PIECE(RESULT,"^",2)

 +6        SET FORMLST=$$FINDID^IBDF18C(DFN,IBDF("APPT"),"",1)

 +7        IF FORMLST]""

               IF IBDF("CLINIC")'=$PIECE(^IBD(357.96,+FORMLST,0),"^",10)

                   SET FORMLST=""

 +8        IF FORMLST=""

               WRITE !,"No forms Printed for Patient"

               DO ANYWAY

               IF IBQUIT

                   GOTO STRTQ

 +9       ;D PAUSE^IBDFDE G OVERQ

           IF FORMLST=""

               GOTO OVERQ

 +10       FOR IBDX=1:1

               SET IBDF("FORM")=$PIECE(FORMLST,"^",IBDX)

               if IBDF("FORM")=""

                   QUIT

               IF IBDF("FORM")'=""

                   DO EN^IBDFDE

                   KILL IBDSEL,IBDPI

                   if IBQUIT

                       QUIT

 +11       WRITE !!

 +12      ;S IBDF("CLINIC")=IBDSC

OVERQ      GOTO OVER

 +1       ;

STRTQ     ;D PAUSE^IBDFDE

 +1        if IBQUIT

               GOTO END

 +2        GOTO APPT

 +3       ;

ANYWAY    ; -- if no forms available ask if want to enter form anyway

 +1       ;    all to use default form, clinic setup,or any form

 +2       ;

 +3        NEW X,Y,DIR,DIRUT

 +4        SET DIR("?")="If you wish to enter data for this patient anyway, chose whether to use the default form, select any form, or use the clinic setup.  Answer None if you don't wish to enter any data."

 +5        SET DIR("A")="Enter Data from [A]ny form, [C]linic Setup, [D]efault, [N]one: "

 +6        SET DIR(0)="SA^A:ANYFORM;C:CLINIC SETUP;D:DEFAULT;N:NONE"

           SET DIR("B")="CLINIC SETUP"

 +7        IF '$DATA(CLSETUP)

               IF +$GET(IBDF("CLINIC"))

                   SET CLNAME=$PIECE($GET(^SC(+IBDF("CLINIC"),0)),"^")

                   SET CLSETUP=$GET(^SD(409.95,+$ORDER(^SD(409.95,"B",+IBDF("CLINIC"),0)),0))

 +8        IF CLSETUP=""

               SET DIR("B")="DEFAULT"

               WRITE !,"No Forms Defined for Clinic"

 +9        DO ^DIR

           KILL DIR

 +10       IF $DATA(DUOUT)!($DATA(DTOUT))

               SET IBQUIT=1

               GOTO ANYWAYQ

 +11       IF $DATA(DIRUT)

               GOTO ANYWAYQ

 +12       SET ANS=Y

 +13       IF ANS="N"

               GOTO ANYWAYQ

 +14      ;

 +15       IF ANS="D"

               Begin DoDot:1

 +16               SET IBFORM=$PIECE($GET(^IBD(357.09,1,0)),"^",4)

 +17               IF IBFORM=""

                       SET IBFORM=$ORDER(^IBE(357,"B","PRIMARY CARE SAMPLE V2.1",0))

 +18               SET FORMLST=$$OTHFRM(IBFORM)

 +19               QUIT

               End DoDot:1

               GOTO ANYWAYQ

 +20      ;

 +21       IF ANS="A"

               Begin DoDot:1

 +22               SET DIC("S")="I $P(^(0),U)'=""GARBAGE"",$P(^(0),U)'=""TOOL KIT"""

 +23               SET DIC="^IBE(357,"

                   SET DIC(0)="AEQM"

                   DO ^DIC

                   KILL DIC

                   if +Y<1

                       QUIT

 +24               SET IBFORM=+Y

 +25               SET FORMLST=$$OTHFRM(IBFORM)

 +26               QUIT

               End DoDot:1

               GOTO ANYWAYQ

 +27      ;

 +28       IF ANS="C"

               Begin DoDot:1

 +29               FOR IBD=2,6,8,9,3,4

                       SET IBFORM=$PIECE(CLSETUP,"^",IBD)

                       IF IBFORM

                           WRITE !

                           SET FORMLST=FORMLST_$$OTHFRM(IBFORM)_"^"

 +30               IF FORMLST=""

                       WRITE !!,"No forms defined for clinic"

 +31               QUIT

               End DoDot:1

               GOTO ANYWAYQ

ANYWAYQ    QUIT

 +1       ;

OTHFRM(IBFORM) ; -- if no form printed, add form tracking entry,

 +1       ; -- compile form if necessary return form list

 +2        NEW FORMID,FORMLST

 +3        SET FORMID=$PIECE($GET(^IBE(357,IBFORM,0)),"^",13)

 +4        IF FORMID=""

               Begin DoDot:1

 +5                WRITE !,"Please wait, Creating the necessary entry..."

 +6                LOCK +^IBE(357,IBFORM):1

 +7                SET FORMID=$$FORMTYPE^IBDF18D(1)

                   WRITE "."

 +8                SET $PIECE(^IBD(357.95,FORMID,0),"^",21)=IBFORM

                   WRITE "."

 +9                SET $PIECE(^IBE(357,IBFORM,0),"^",13)=FORMID

 +10               if $PIECE(^IBE(357,IBFORM,0),"^",13)

                       SET ^IBE(357,"ADEF",$PIECE(^IBE(357,IBFORM,0),"^",13),IBFORM)=""

 +11               LOCK -^IBE(357,IBFORM)

               End DoDot:1

 +12       SET FORMLST=+$$FID^IBDF18C(DFN,IBDF("APPT"),1,FORMID,IBDF("CLINIC"))

 +13       SET DIE="^IBD(357.96,"

           SET DR=".11////20"

           SET DA=FORMLST

           DO ^DIE

           KILL DA,DR,DIC,DIE

 +14      ;

 +15       QUIT FORMLST

 +16      ;

SELCL()   ; -- select clinic

 +1        SET IBQUIT=0

 +2        NEW DIR,DA,DR,DIC,DIE,X,Y,ANS,DIRUT

 +3        SET ANS=-1

 +4        SET DIR("?")="Enter the name of the clinic that you are entering encounter forms for."

 +5        SET DIR("S")="I $P(^(0),U,3)=""C"""

 +6        SET DIR(0)="PO^44:AEQM"

           SET DIR("A")="Select Clinic"

           DO ^DIR

           KILL DIR,DA,DR,DIC

 +7        IF $DATA(DUOUT)!($DATA(DTOUT))

               SET IBQUIT=1

               GOTO SELCLQ

 +8        IF $DATA(DIRUT)

               GOTO SELCLQ

 +9        SET ANS=+Y

SELCLQ     QUIT ANS

 +1       ;

 +2       ;

SELAP(IBDF) ; -- select appointment date for a clinic

 +1        SET IBQUIT=0

 +2        NEW DIR,DA,DR,DIC,DIE,X,Y,ANS,DIRUT

 +3        SET ANS=-1

 +4       ;I $G(LASTDATE)?7N S DIR("B")=$$FMTE^XLFDT(LASTDATE)

 +5       ;R !,"Appointment Date: ",X:$G(DTIME)

 +6        SET DIR(0)="DO^:DT:EX"

           SET DIR("A")="Appointment Date"

 +7        SET DIR("?")="Enter the date for the clinic that you wish to enter encounter forms for"

 +8        SET DIR("??")="^D APDT^IBDFDE6"

 +9        DO ^DIR

           KILL DIR

 +10       IF $DATA(DUOUT)!($DATA(DTOUT))

               SET IBQUIT=1

               GOTO SELAPQ

 +11       IF $DATA(DIRUT)

               GOTO SELAPQ

 +12       SET ANS=+Y

SELAPQ     QUIT ANS

 +1       ;

SELPT     ; -- select patient(s) to process

 +1        SET IBDCLIN=IBDF("CLINIC")

           NEW ARRAY,CNT,IBD

           KILL IBDF,IBDCO,PXCA,SEL

           SET IBDF("CLINIC")=IBDCLIN

           KILL IBDCLIN

 +2        SET (ARRAY,RESULT,ANS)=""

           SET (IBQUIT,CNT)=0

 +3        SET DIR("?")="Enter the listed number or the name of the patient or the last 4 number of the SSN or the first letter of the last name with the last 4 numbers of the SSN."

 +4        SET DIR("??")="^D LIST^IBDFDE6"

 +5        SET DIR(0)="FO^1:30"

           SET DIR("A")="Select Patient"

 +6        DO ^DIR

           KILL DIR

 +7        IF $DATA(DUOUT)!($DATA(DTOUT))

               SET IBQUIT=1

               GOTO SELQ

 +8        SET ANS=$$UP^XLFSTR(Y)

 +9        IF ANS=""

               GOTO SELQ

 +10       IF $DATA(DIRUT)

               SET IBQUIT=1

               GOTO SELQ

 +11       IF ANS=+ANS

               SET ARRAY="IBD-PL"

               IF $DATA(^TMP(ARRAY,$JOB,IBDF("CLINIC"),ANS))

                   SET RESULT=^(ANS)

                   WRITE "   ",$PIECE($GET(^DPT(+RESULT,0)),"^")

                   GOTO SELQ

 +12      ;

 +13       IF ANS?4N

               SET ARRAY="IBD-PL4"

               DO ARRAY(ARRAY,ANS)

               GOTO FIND

 +14       IF ANS?1A4N

               SET ARRAY="IBD-PLB"

               DO ARRAY(ARRAY,ANS)

               GOTO FIND

 +15       SET ARRAY="IBD-PLN"

           DO ARRAY(ARRAY,ANS)

           Begin DoDot:1

 +16           SET NAME=ANS

FOR

                   SET NAME=$ORDER(^TMP(ARRAY,$JOB,IBDF("CLINIC"),NAME))

                   if $EXTRACT(NAME,1,$LENGTH(ANS))'=ANS

                       QUIT

                   DO ARRAY(ARRAY,NAME)

           End DoDot:1

           GOTO FIND

 +17       GOTO SELQ

FIND      ;find appropriate pt appt from array

 +1        IF CNT=1

               SET RESULT=$GET(^TMP(ARRAY,$JOB,IBDF("CLINIC"),$PIECE(IBD(CNT),"^",2),+IBD(CNT)))

               if $DATA(RESULT)

                   Begin DoDot:1

 +2                    IF ARRAY="IBD-PLN"

                           WRITE "   ",$EXTRACT($PIECE($GET(^DPT(+RESULT,0)),"^"),($LENGTH(ANS)+1),999)

                           QUIT

 +3                    WRITE "   ",$PIECE($GET(^DPT(+RESULT,0)),"^")

                   End DoDot:1

               GOTO SELQ

 +4        SET RESULT=$$MULT^IBDFDE61(CNT,.IBD)

           if $DATA(RESULT)

               Begin DoDot:1

 +5                WRITE "   ",$PIECE($GET(^DPT(+RESULT,0)),"^")

               End DoDot:1

 +6        IF RESULT=""

               WRITE $CHAR(7),"  ??  Not Found"

               SET RESULT=-1

 +7       ;

SELQ       QUIT

 +1       ;

ARRAY(ARRAY,ANS) ; -- bld array of multiple patients

 +1       ; -- required variables:  array = name x-ref; ans = name of selection

 +2        SET A=0

FOR

               SET A=$ORDER(^TMP(ARRAY,$JOB,IBDF("CLINIC"),ANS,A))

               if 'A

                   QUIT

               SET CNT=CNT+1

               SET IBD(CNT)=A_"^"_ANS

 +3        QUIT

BLD       ; -- Find all appointments for a date

 +1        KILL ^TMP("IBD-PL",$JOB),^TMP("IBD-PLN",$JOB)

 +2        NEW SC,IBD,IBD1,NODE,SNODE

 +3        SET IBD=IBDFDT

           SET SC=IBDF("CLINIC")

           SET CNT=0

 +4        FOR

               SET IBD=$ORDER(^SC(SC,"S",IBD))

               if 'IBD!(IBD>(IBDFDT+.24))

                   QUIT

               Begin DoDot:1

 +5                SET IBD1=0

FOR

                       SET IBD1=$ORDER(^SC(SC,"S",IBD,1,IBD1))

                       if 'IBD1

                           QUIT

                       Begin DoDot:2

 +6                        SET NODE=$GET(^SC(SC,"S",IBD,1,IBD1,0))

 +7                        SET SNODE=$GET(^DPT(+NODE,"S",IBD,0))

 +8                        SET X=$PIECE(SNODE,"^",2)

 +9       ;inpatient appointments are okay

                           IF X'=""

                               IF "CNAPCA"[X

                                   QUIT

 +10                       SET (DFN,IBDF("DFN"))=+NODE

 +11                       SET CNT=CNT+1

 +12                       SET ^TMP("IBD-PL",$JOB,SC,CNT)=DFN_"^"_IBD_"^"_SNODE

 +13                       SET ^TMP("IBD-PLN",$JOB,SC,$PIECE(^DPT(DFN,0),"^"),CNT)=DFN_"^"_IBD_"^"_SNODE

 +14                       SET ^TMP("IBD-PLB",$JOB,SC,$EXTRACT($PIECE(^DPT(DFN,0),"^",1),1)_$EXTRACT($PIECE(^DPT(DFN,0),"^",9),6,9),CNT)=DFN_"^"_IBD_"^"_SNODE

 +15                       SET ^TMP("IBD-PL4",$JOB,SC,$EXTRACT($PIECE(^DPT(DFN,0),"^",9),6,9),CNT)=DFN_"^"_IBD_"^"_SNODE

                       End DoDot:2

               End DoDot:1

 +16       QUIT

 +17      ;

LIST      ; -- print list of patients

 +1        NEW IBD,IBJ,FORM,STATUS,CNT,X,IBQUIT

 +2        SET IBQUIT=0

 +3        SET IBD=0

FOR

               SET IBD=$ORDER(^TMP("IBD-PL",$JOB,IBDF("CLINIC"),IBD))

               if 'IBD!(IBQUIT)

                   QUIT

               SET NODE=$GET(^TMP("IBD-PL",$JOB,IBDF("CLINIC"),IBD))

               DO ONE(NODE,IBD)

               IF '(IBD#15)

                   DO ASKPT^IBDFDE61(IBD)

 +4        QUIT

 +5       ;

ONE(NODE,IBD1) ; -- write one line

 +1        NEW CNT,C

 +2        if $GET(NODE)=""

               QUIT

 +3        SET DFN=+NODE

           SET APPT=$PIECE(NODE,"^",2)

 +4        SET FORM=$$FINDID^IBDF18C(DFN,APPT,"",1)

           SET STATUS="NO FORM PRINTED"

 +5        SET CNT=0

           FOR IBJ=1:1

               SET X=$PIECE(FORM,"^",IBJ)

               if X=""

                   QUIT

               SET CNT=CNT+1

 +6        IF +FORM

               SET Y=$PIECE($GET(^IBD(357.96,+FORM,0)),"^",11)

               SET C=$PIECE(^DD(357.96,.11,0),"^",2)

               DO Y^DIQ

               SET STATUS=Y

 +7        WRITE !?2,IBD1,?5,$EXTRACT($PIECE(^DPT(DFN,0),"^"),1,18),?26,$PIECE($GET(^DPT(DFN,.36)),"^",4),?32,$$FMTE^XLFDT(+APPT),?52,$EXTRACT($GET(STATUS),1,24),?77,"("_CNT_")"

 +8        QUIT

 +9       ;

APDT      ; -- list last 30 days appointment dates in clinic

 +1        SET (X,Y)=$$FMADD^XLFDT(DT,-62)

           SET CNT=0

 +2        FOR

               SET X=$ORDER(^SC(IBDF("CLINIC"),"S",X))

               if 'X!(X>DT)

                   QUIT

               Begin DoDot:1

 +3                IF $EXTRACT(X,1,7)=Y

                       QUIT

 +4                SET Y=$EXTRACT(X,1,7)

                   SET CNT=CNT+1

 +5                IF CNT=1

                       WRITE !!,"The following are valid Appointment dates in the past 60 days:"

 +6                if (CNT#4=1)

                       WRITE !,?3,$$FMTE^XLFDT(Y)

 +7                if (CNT#4=2)

                       WRITE ?20,$$FMTE^XLFDT(Y)

 +8                if (CNT#4=3)

                       WRITE ?40,$$FMTE^XLFDT(Y)

 +9                if (CNT#4=0)

                       WRITE ?60,$$FMTE^XLFDT(Y)

               End DoDot:1

 +10       QUIT

 +11      ;

HDR       ; -- print Clinic header

 +1        NEW CNT,IBD,IBD1

           WRITE @IOF

 +2        SET CNT=0

 +3        FOR IBD=2,6,8,9,3,4

               SET IBD1=$PIECE(CLSETUP,"^",IBD)

               IF IBD1

                   SET CNT=CNT+1

 +4        WRITE !,"      Clinic: ",$EXTRACT(CLNAME,1,25)

           WRITE ?40,"         Date: ",$$FMTE^XLFDT(IBDFDT)

 +5        SET FORM=$PIECE(CLSETUP,"^",2)

           SET IBDFMNME=$PIECE($GET(^IBE(357,+FORM,0)),"^")

 +6        WRITE !,"  Basic Form: ",$EXTRACT(IBDFMNME,1,25)

           WRITE ?40," Active Forms: ",CNT

 +7        WRITE !,"Appointments: ",$ORDER(^TMP("IBD-PL",$JOB,IBDF("CLINIC"),""),-1)

 +8        WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","=")

 +9        QUIT

 +10      ;

END        KILL I,J,X,Y,DA,DR,DIC,DIE,DIR,DTOUT,DUOUT,DIRUT,IBDSEL,CHOICE,TEXT,TEXTU,RESULT,IBDPI,IBDCO,IBDF

 +1        KILL ^TMP("IBD-PL",$JOB),^TMP("IBD-PLN",$JOB),^TMP("IBD-PLB",$JOB),^TMP("IBD-PL4",$JOB),^TMP("IBD-MORE",$JOB),^TMP("IBD-PLCHK",$JOB)

 +2        KILL ^TMP("IBD-ASK",$JOB),^TMP("IBD-LCODE",$JOB),^TMP("IBD-LST",$JOB),^TMP("IBD-LTEXT",$JOB),^TMP("IBD-OBJ",$JOB)

 +3        QUIT

IBDFDE6.m