IBDFCNOF.m

IBDFCNOF ;ALB/CJM - AICS clinics with no forms ; JUL 20,1993

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

 ;

% ; -- list of clinics that have no encounter forms in use.

 ;

 N C,X,Y,SERV,SERVICE,CLINIC,IBHDT,IBDFIFN,IBDCNO,IBDFCNO,IBDFNODE,PAGE,IBQUIT,DIVIS,DIVNAM,VAUTD,MULTI

 W !!,"AICS List of Clinics with No Encounter Form in Use",!!

 S IBQUIT=0

 D DIVIS G:IBQUIT EXIT

 D DEVICE G:IBQUIT EXIT

 D DQ

 Q

 ;

EXIT ; -- end of report

 K ^TMP($J,"IBDCN")

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

 D ^%ZISC

 K ZTSK,ZTDESC,ZTSAVE,ZTRTN

 Q

 ;

DQ ; -- entry point from taskmanager

 K ^TMP($J,"IBDCN")

 S IBQUIT=0,PAGE=1

 S IBHDT=$$HTE^XLFDT($H,1)

 D SET,LIST G EXIT

 Q

 ;

SET ; -- build list into temporary array

 N IBDFCL,DIVIS,DIVNAM,SERVICE,CLINNAM,IBDFNODE,IBQUIT

 F IBDFIFN=0:0 S IBDFIFN=$O(^SC(IBDFIFN)) Q:'IBDFIFN  S IBDCNO=$G(^SC(IBDFIFN,0)) I $P(IBDCNO,"^",3)="C" D

 .S DIVIS=+$P(IBDCNO,"^",15) I DIVIS=0 S DIVIS=$S(MULTI=0:$P($G(^DG(43,1,"GL")),"^",3),1:"Unknown")

 .S DIVNAM=$P($G(^DG(40.8,+DIVIS,0)),"^") S:DIVNAM="" DIVNAM="Unknown"

 .S CLINNAM=$P(IBDCNO,"^")

 .S Y=$P(IBDCNO,"^",8),C=$P(^DD(44,9,0),"^",2) D Y^DIQ S SERVICE=Y S:SERVICE="" SERVICE="Unknown"

 .I $O(^SD(409.95,"B",IBDFIFN,0)) D  ; else follows

 ..S IBDFCL=$O(^SD(409.95,"B",IBDFIFN,0))

 ..S IBDFNODE=^SD(409.95,IBDFCL,0)

 ..S IBQUIT=0 F X=2:1:9 S:$P(IBDFNODE,"^",X)&("^1^2^3^4^5^6^8^9^"[X) IBQUIT=1 Q:IBQUIT

 ..I 'IBQUIT S ^TMP($J,"IBDCN",DIVIS,DIVNAM,SERVICE,CLINNAM)=IBDFIFN_"^"_$S($P(IBDFNODE,"^",7)]"":"FORM IN PROGRESS",1:"") S ^TMP($J,"IBDCN",DIVIS,0)=$G(^TMP($J,"IBDCN",DIVIS,0))+1

 .I '$O(^SD(409.95,"B",IBDFIFN,0)) S ^TMP($J,"IBDCN",DIVIS,DIVNAM,SERVICE,CLINNAM)=IBDFIFN,^TMP($J,"IBDCN",DIVIS,0)=$G(^TMP($J,"IBDCN",DIVIS,0))+1

 Q

 ;

HEADER ; -- writes the report header

 I $E(IOST,1,2)="C-",$Y>1,PAGE>1 D PAUSE Q:IBQUIT

 I PAGE>1 W @IOF

 W !,"List of Clinics Without Encounter Forms",?IOM-32,IBHDT,"   PAGE ",PAGE

 W !,"For Division: ",DIVNAM

 ;W !,"CLINICS",?27,"SERVICE",?47,"DIVISION"

 W !,"CLINICS",?27,"SERVICE",?47,"COMMENT"

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

 S PAGE=PAGE+1

 Q

 ;

PAUSE ; -- hold crt 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

 ;

LIST ; -- lists the clinics using FORM

 N CLINIC,COUNT,DIR,NEWDIV,NAME,OLDDIV

 W:$E(IOST,1,2)="C-" @IOF

 I $D(^TMP($J,"IBDCN"))=0 W ?15,"No active clinics found without an assigned encounter form"

 S (NEWDIV,COUNT)=0,OLDDIV=""

 S DIVIS="" F  S DIVIS=$O(^TMP($J,"IBDCN",DIVIS)) Q:DIVIS=""!(IBQUIT)  D

 .I 'VAUTD,'$D(VAUTD(DIVIS)) Q

 .I 'VAUTD,'$D(^TMP($J,"IBDCN",DIVIS)) S DIVNAM=$P($G(^DG(40.8,+DIVIS,0)),"^") D HEADER W !,"No clinics found for division '",DIVNAM,"'",! Q

 .S DIVNAM=$O(^TMP($J,"IBDCN",DIVIS,0)) Q:DIVNAM=""

 .S NEWDIV=1

 .S SERV="" F  S SERV=$O(^TMP($J,"IBDCN",DIVIS,DIVNAM,SERV)) Q:SERV=""!(IBQUIT)  D

 ..S NAME="" F  S NAME=$O(^TMP($J,"IBDCN",DIVIS,DIVNAM,SERV,NAME)) Q:NAME=""!(IBQUIT)  S CLINIC=+^(NAME) D ONELINE

 I 'IBQUIT W:OLDDIV'="" !,"----------------",!,"Division Count = ",COUNT

 Q

 ;

ONELINE ; -- print line of report

 I $G(NEWDIV) D NEWDIV Q:IBQUIT

 I $Y>(IOSL-3) D HEADER Q:IBQUIT

 ;W !,$E(NAME,1,25),?27,$E(SERV,1,18),?47,$E(DIVNAM,1,15)

 W !,$E(NAME,1,25),?27,$E(SERV,1,18)

 W ?47,$P(^TMP($J,"IBDCN",DIVIS,DIVNAM,SERV,NAME),"^",2),"  "

 I '$$ACLN(CLINIC) W ?4,"(Clinic Currently Inactive)"

 S COUNT=COUNT+1

 Q

 ;

NEWDIV ; -- print division totals and start new division

 I 'IBQUIT W:OLDDIV'="" !,"----------------",!,"Division Count = ",COUNT

 S OLDDIV=DIVIS

 D HEADER Q:IBQUIT

 W !?10,"Division: ",DIVNAM,! S NEWDIV=0,COUNT=0

 Q

 ;

DEVICE ; -- select device

 I $D(ZTQUEUED) Q

 S %ZIS="MQ" D ^%ZIS I POP S IBQUIT=1 Q

 I $D(IO("Q")) S ZTRTN="DQ^IBDFCNOF",ZTDESC="IBD - Clinics with No Forms",ZTSAVE("VA*")="",ZTSAVE("MULTI")="" D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued Task="_ZTSK,1:"Request Canceled") D HOME^%ZIS S IBQUIT=1 Q

 U IO

 Q

 ;

DIVIS ; -- Select division

 N X,Y S VAUTD=1,MULTI=0

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

 I 'VAUTD S X="" F  S X=$O(VAUTD(X)) Q:'X  S ^TMP($J,"IBDCN",X)=""

 Q

 ;

ACLN(SC) ; function

 ; -- is clinic currently active

 ;    Input   SC := pointer to 44

 ;    Output     := 1 if currently active

 ;                  0 if currently inactive

 ;

 N FLAG,SDIN,SDRE S FLAG=1

 I $D(^SC(SC,"I")) S Y=^("I"),SDIN=+Y,SDRE=+$P(Y,U,2)

 I $G(SDIN),SDIN'>DT,SDRE,SDRE>DT S FLAG=0

 I $G(SDIN),SDIN'>DT,'SDRE S FLAG=0

ACLNQ Q FLAG

IBDFCNOF  ;ALB/CJM - AICS clinics with no forms ; JUL 20,1993

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

 +2       ;

%         ; -- list of clinics that have no encounter forms in use.

 +1       ;

 +2        NEW C,X,Y,SERV,SERVICE,CLINIC,IBHDT,IBDFIFN,IBDCNO,IBDFCNO,IBDFNODE,PAGE,IBQUIT,DIVIS,DIVNAM,VAUTD,MULTI

 +3        WRITE !!,"AICS List of Clinics with No Encounter Form in Use",!!

 +4        SET IBQUIT=0

 +5        DO DIVIS

           IF IBQUIT

               GOTO EXIT

 +6        DO DEVICE

           IF IBQUIT

               GOTO EXIT

 +7        DO DQ

 +8        QUIT 

 +9       ;

EXIT      ; -- end of report

 +1        KILL ^TMP($JOB,"IBDCN")

 +2        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

               QUIT 

 +3        DO ^%ZISC

 +4        KILL ZTSK,ZTDESC,ZTSAVE,ZTRTN

 +5        QUIT 

 +6       ;

DQ        ; -- entry point from taskmanager

 +1        KILL ^TMP($JOB,"IBDCN")

 +2        SET IBQUIT=0

           SET PAGE=1

 +3        SET IBHDT=$$HTE^XLFDT($HOROLOG,1)

 +4        DO SET

           DO LIST

           GOTO EXIT

 +5        QUIT 

 +6       ;

SET       ; -- build list into temporary array

 +1        NEW IBDFCL,DIVIS,DIVNAM,SERVICE,CLINNAM,IBDFNODE,IBQUIT

 +2        FOR IBDFIFN=0:0

               SET IBDFIFN=$ORDER(^SC(IBDFIFN))

               IF 'IBDFIFN

                   QUIT 

               SET IBDCNO=$GET(^SC(IBDFIFN,0))

               IF $PIECE(IBDCNO,"^",3)="C"

                   Begin DoDot:1

 +3                    SET DIVIS=+$PIECE(IBDCNO,"^",15)

                       IF DIVIS=0

                           SET DIVIS=$SELECT(MULTI=0:$PIECE($GET(^DG(43,1,"GL")),"^",3),1:"Unknown")

 +4                    SET DIVNAM=$PIECE($GET(^DG(40.8,+DIVIS,0)),"^")

                       IF DIVNAM=""

                           SET DIVNAM="Unknown"

 +5                    SET CLINNAM=$PIECE(IBDCNO,"^")

 +6                    SET Y=$PIECE(IBDCNO,"^",8)

                       SET C=$PIECE(^DD(44,9,0),"^",2)

                       DO Y^DIQ

                       SET SERVICE=Y

                       IF SERVICE=""

                           SET SERVICE="Unknown"

 +7       ; else follows

                       IF $ORDER(^SD(409.95,"B",IBDFIFN,0))

                           Begin DoDot:2

 +8                            SET IBDFCL=$ORDER(^SD(409.95,"B",IBDFIFN,0))

 +9                            SET IBDFNODE=^SD(409.95,IBDFCL,0)

 +10                           SET IBQUIT=0

                               FOR X=2:1:9

                                   IF $PIECE(IBDFNODE,"^",X)&("^1^2^3^4^5^6^8^9^"[X)

                                       SET IBQUIT=1

                                   IF IBQUIT

                                       QUIT 

 +11                           IF 'IBQUIT

                                   SET ^TMP($JOB,"IBDCN",DIVIS,DIVNAM,SERVICE,CLINNAM)=IBDFIFN_"^"_$SELECT($PIECE(IBDFNODE,"^",7)]"":"FORM IN PROGRESS",1:"")

                                   SET ^TMP($JOB,"IBDCN",DIVIS,0)=$GET(^TMP($JOB,"IBDCN",DIVIS,0))+1

                           End DoDot:2

 +12                   IF '$ORDER(^SD(409.95,"B",IBDFIFN,0))

                           SET ^TMP($JOB,"IBDCN",DIVIS,DIVNAM,SERVICE,CLINNAM)=IBDFIFN

                           SET ^TMP($JOB,"IBDCN",DIVIS,0)=$GET(^TMP($JOB,"IBDCN",DIVIS,0))+1

                   End DoDot:1

 +13       QUIT 

 +14      ;

HEADER    ; -- writes the report header

 +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 Clinics Without Encounter Forms",?IOM-32,IBHDT,"   PAGE ",PAGE

 +4        WRITE !,"For Division: ",DIVNAM

 +5       ;W !,"CLINICS",?27,"SERVICE",?47,"DIVISION"

 +6        WRITE !,"CLINICS",?27,"SERVICE",?47,"COMMENT"

 +7        WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")

 +8        SET PAGE=PAGE+1

 +9        QUIT 

 +10      ;

PAUSE     ; -- hold crt 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       ;

LIST      ; -- lists the clinics using FORM

 +1        NEW CLINIC,COUNT,DIR,NEWDIV,NAME,OLDDIV

 +2        IF $EXTRACT(IOST,1,2)="C-"

               WRITE @IOF

 +3        IF $DATA(^TMP($JOB,"IBDCN"))=0

               WRITE ?15,"No active clinics found without an assigned encounter form"

 +4        SET (NEWDIV,COUNT)=0

           SET OLDDIV=""

 +5        SET DIVIS=""

           FOR 

               SET DIVIS=$ORDER(^TMP($JOB,"IBDCN",DIVIS))

               IF DIVIS=""!(IBQUIT)

                   QUIT 

               Begin DoDot:1

 +6                IF 'VAUTD

                       IF '$DATA(VAUTD(DIVIS))

                           QUIT 

 +7                IF 'VAUTD

                       IF '$DATA(^TMP($JOB,"IBDCN",DIVIS))

                           SET DIVNAM=$PIECE($GET(^DG(40.8,+DIVIS,0)),"^")

                           DO HEADER

                           WRITE !,"No clinics found for division '",DIVNAM,"'",!

                           QUIT 

 +8                SET DIVNAM=$ORDER(^TMP($JOB,"IBDCN",DIVIS,0))

                   IF DIVNAM=""

                       QUIT 

 +9                SET NEWDIV=1

 +10               SET SERV=""

                   FOR 

                       SET SERV=$ORDER(^TMP($JOB,"IBDCN",DIVIS,DIVNAM,SERV))

                       IF SERV=""!(IBQUIT)

                           QUIT 

                       Begin DoDot:2

 +11                       SET NAME=""

                           FOR 

                               SET NAME=$ORDER(^TMP($JOB,"IBDCN",DIVIS,DIVNAM,SERV,NAME))

                               IF NAME=""!(IBQUIT)

                                   QUIT 

                               SET CLINIC=+^(NAME)

                               DO ONELINE

                       End DoDot:2

               End DoDot:1

 +12       IF 'IBQUIT

               IF OLDDIV'=""

                   WRITE !,"----------------",!,"Division Count = ",COUNT

 +13       QUIT 

 +14      ;

ONELINE   ; -- print line of report

 +1        IF $GET(NEWDIV)

               DO NEWDIV

               IF IBQUIT

                   QUIT 

 +2        IF $Y>(IOSL-3)

               DO HEADER

               IF IBQUIT

                   QUIT 

 +3       ;W !,$E(NAME,1,25),?27,$E(SERV,1,18),?47,$E(DIVNAM,1,15)

 +4        WRITE !,$EXTRACT(NAME,1,25),?27,$EXTRACT(SERV,1,18)

 +5        WRITE ?47,$PIECE(^TMP($JOB,"IBDCN",DIVIS,DIVNAM,SERV,NAME),"^",2),"  "

 +6        IF '$$ACLN(CLINIC)

               WRITE ?4,"(Clinic Currently Inactive)"

 +7        SET COUNT=COUNT+1

 +8        QUIT 

 +9       ;

NEWDIV    ; -- print division totals and start new division

 +1        IF 'IBQUIT

               IF OLDDIV'=""

                   WRITE !,"----------------",!,"Division Count = ",COUNT

 +2        SET OLDDIV=DIVIS

 +3        DO HEADER

           IF IBQUIT

               QUIT 

 +4        WRITE !?10,"Division: ",DIVNAM,!

           SET NEWDIV=0

           SET COUNT=0

 +5        QUIT 

 +6       ;

DEVICE    ; -- select device

 +1        IF $DATA(ZTQUEUED)

               QUIT 

 +2        SET %ZIS="MQ"

           DO ^%ZIS

           IF POP

               SET IBQUIT=1

               QUIT 

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

               SET ZTRTN="DQ^IBDFCNOF"

               SET ZTDESC="IBD - Clinics with No Forms"

               SET ZTSAVE("VA*")=""

               SET ZTSAVE("MULTI")=""

               DO ^%ZTLOAD

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

               DO HOME^%ZIS

               SET IBQUIT=1

               QUIT 

 +4        USE IO

 +5        QUIT 

 +6       ;

DIVIS     ; -- Select division

 +1        NEW X,Y

           SET VAUTD=1

           SET MULTI=0

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

               SET MULTI=1

               DO DIVISION^VAUTOMA

               IF Y=-1

                   SET IBQUIT=1

 +3        IF 'VAUTD

               SET X=""

               FOR 

                   SET X=$ORDER(VAUTD(X))

                   IF 'X

                       QUIT 

                   SET ^TMP($JOB,"IBDCN",X)=""

 +4        QUIT 

 +5       ;

ACLN(SC)  ; function

 +1       ; -- is clinic currently active

 +2       ;    Input   SC := pointer to 44

 +3       ;    Output     := 1 if currently active

 +4       ;                  0 if currently inactive

 +5       ;

 +6        NEW FLAG,SDIN,SDRE

           SET FLAG=1

 +7        IF $DATA(^SC(SC,"I"))

               SET Y=^("I")

               SET SDIN=+Y

               SET SDRE=+$PIECE(Y,U,2)

 +8        IF $GET(SDIN)

               IF SDIN'>DT

                   IF SDRE

                       IF SDRE>DT

                           SET FLAG=0

 +9        IF $GET(SDIN)

               IF SDIN'>DT

                   IF 'SDRE

                       SET FLAG=0

ACLNQ      QUIT FLAG