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
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFCNOF 4510 printed Oct 16, 2024@18:52:54 Page 2
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 ;
+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
