XDRDPRE1 ;SF-IRMFO.SEA/JLI - GENERATE LISTS OF PATIENTS IDENTIFIED BY THE PRELIMINARY SCAN ;02/23/2000 08:48
;;7.3;TOOLKIT;**23,46**;Apr 25, 1995
;;
EN ;
S XDRFL=+$$FILE^XDRDPICK() G:XDRFL'>0 EXIT S XDRFNAM=$P(^DIC(XDRFL,0),U)
I '$D(^XTMP("XDRDPREL",XDRFL," DONE")) D Q:XDRFL=0
. I $D(^XTMP("XDRDPREL",XDRFL," TIME")) D Q:XDRFL=0
. . I $$HDIFF^XLFDT($H,^XTMP("XDRDPREL",XDRFL," TIME"),2)>300 Q
. . W !!,"There appears to be a job already running. You may either"
. . W !,"view those data or check back in about 5 minutes.",!!
. . S XDRFL=0
. W !!,$C(7),"There is no available data to generate a list from. You will need to accumulate",!,"the data.",!!
. D ^XDRDPREL
. S XDRFL=0
D SELECT I XDRSELEC="" Q
S %ZIS="Q" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTSAVE("XDRFL")="",ZTSAVE("XDRSELEC")="",ZTIO=ION,ZTRTN="DQ^XDRDPRE1",ZTDESC="XDRDPRE1 LIST OF PROBLEMS" D ^%ZTLOAD W:$D(ZTSK) !,"Queued as task "_ZTSK,! Q
;
DQ ;
U IO W @IOF
S XDRTMP="^XTMP(""XDRDPREL"",XDRFL,XDRSELEC,XDRDA)"
S XDRGLB=^DIC(XDRFL,0,"GL")_"XDRDA)"
S XDRDR=".01;"
F XDRI=0:0 S XDRI=$O(^DD(XDRFL,0,"ID",XDRI)) Q:XDRI'>0 S XDRDR=XDRDR_XDRI_";"
I XDRSELEC'="NO ZERO NODE" D SIZE
D HEADER
F XDRDA=0:0 S XDRDA=$O(@XDRTMP) Q:XDRDA'>0 D Q:$D(DIRUT)
. I (IOSL-$Y)<6 D:IOST["C-" Q:$D(DIRUT) W @IOF,!!
. . W ! S DIR(0)="E" D ^DIR
. W !,$J(XDRDA,10)
. I XDRSELEC="NO ZERO NODE" Q
. S DR=XDRDR
. S DA=XDRDA,DIC=XDRFL,DIQ(0)="I",DIQ="XDRX" K XDRX
. D EN^DIQ1
. S X=XDRX(XDRFL,XDRDA,.01,"I")
. F Q:X'["MERGING INTO" S X=$P(X,"(",2,99),X=$E(X,1,$L(X)-1)
. W " ",$E(X,1,28),?40
. F I=0:0 S I=$O(XDRX(XDRFL,XDRDA,I)) Q:I'>0 I I'=.01 D
. . S Y=$P(^DD(XDRFL,I,0),U,2)
. . S X=XDRX(XDRFL,XDRDA,I,"I")
. . I Y["D" S N=10 I X'="" S X=$$FMTE^XLFDT(X,"2D") W $J(X,N)
. . I Y'["D",$D(NSIZE(I)) S N=NSIZE(I)+2 W $J(X,N)
D ^%ZISC
Q
;
SIZE ;
N XDRDA,NC,DR,DA,DIC,DIQ,I,L
S NC=0
F XDRDA=0:0 S XDRDA=$O(@XDRGLB) Q:XDRDA'>0 S NC=NC+1 Q:NC>50 D
. S DR=XDRDR
. S DA=XDRDA,DIC=XDRFL,DIQ(0)="I",DIQ="XDRX" K XDRX
. D EN^DIQ1
. F I=0:0 S I=$O(XDRX(XDRFL,XDRDA,I)) Q:I'>0 D
. . S L=$L(XDRX(XDRFL,XDRDA,I,"I")) I L>$G(NSIZE(I)) S NSIZE(I)=L
Q
;
W "LISTING OF ENTRIES IN FILE ",XDRFL," WITH IDENTIFIER OR OTHER PROBLEMS"
W ?10,"SELECTED LISTING: ",XDRSELEC
W !!!,"DATA LISTED ACROSS THE PAGE IN THE FOLLOWING ORDER:",!!,"INTERNAL ENTRY NUMBER"
I XDRSELEC="NO ZERO NODE" W !! Q
F I=0:0 S I=$O(NSIZE(I)) Q:I'>0 W !,$P(^DD(XDRFL,I,0),U)
W !!,"XXXXXXXXXX XXXXXXXXXXXXXXXXXXXXXXXXXXX",?40
F I=.01:0 S I=$O(NSIZE(I)) Q:I'>0 D
. S X=$P(^DD(XDRFL,I,0),U,2) I X["D" S NSIZE(I)=8
. S X=$E("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX",1,NSIZE(I))
. W $J(X,NSIZE(I)+2)
W !
Q
;
SELECT ;
N NC,N,XDRX,I,DIR,Y
S NC=0
S N="A" F S N=$O(^XTMP("XDRDPREL",XDRFL,N)) Q:N="" S NC=NC+1,XDRX(NC)=N
W !!,"Enter the number of the desired list to output:",!
F I=0:0 S I=$O(XDRX(I)) Q:I'>0 W !,$J(I,2)," ",XDRX(I)
W !! S DIR(0)="N^1:"_NC,DIR("A")="List number" D ^DIR
S XDRSELEC=""
I Y>0 S XDRSELEC=XDRX(+Y)
Q
;
EXIT ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRDPRE1 3102 printed Dec 13, 2024@02:39:10 Page 2
XDRDPRE1 ;SF-IRMFO.SEA/JLI - GENERATE LISTS OF PATIENTS IDENTIFIED BY THE PRELIMINARY SCAN ;02/23/2000 08:48
+1 ;;7.3;TOOLKIT;**23,46**;Apr 25, 1995
+2 ;;
EN ;
+1 SET XDRFL=+$$FILE^XDRDPICK()
if XDRFL'>0
GOTO EXIT
SET XDRFNAM=$PIECE(^DIC(XDRFL,0),U)
+2 IF '$DATA(^XTMP("XDRDPREL",XDRFL," DONE"))
Begin DoDot:1
+3 IF $DATA(^XTMP("XDRDPREL",XDRFL," TIME"))
Begin DoDot:2
+4 IF $$HDIFF^XLFDT($HOROLOG,^XTMP("XDRDPREL",XDRFL," TIME"),2)>300
QUIT
+5 WRITE !!,"There appears to be a job already running. You may either"
+6 WRITE !,"view those data or check back in about 5 minutes.",!!
+7 SET XDRFL=0
End DoDot:2
if XDRFL=0
QUIT
+8 WRITE !!,$CHAR(7),"There is no available data to generate a list from. You will need to accumulate",!,"the data.",!!
+9 DO ^XDRDPREL
+10 SET XDRFL=0
End DoDot:1
if XDRFL=0
QUIT
+11 DO SELECT
IF XDRSELEC=""
QUIT
+12 SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
+13 IF $DATA(IO("Q"))
SET ZTSAVE("XDRFL")=""
SET ZTSAVE("XDRSELEC")=""
SET ZTIO=ION
SET ZTRTN="DQ^XDRDPRE1"
SET ZTDESC="XDRDPRE1 LIST OF PROBLEMS"
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Queued as task "_ZTSK,!
QUIT
+14 ;
DQ ;
+1 USE IO
WRITE @IOF
+2 SET XDRTMP="^XTMP(""XDRDPREL"",XDRFL,XDRSELEC,XDRDA)"
+3 SET XDRGLB=^DIC(XDRFL,0,"GL")_"XDRDA)"
+4 SET XDRDR=".01;"
+5 FOR XDRI=0:0
SET XDRI=$ORDER(^DD(XDRFL,0,"ID",XDRI))
if XDRI'>0
QUIT
SET XDRDR=XDRDR_XDRI_";"
+6 IF XDRSELEC'="NO ZERO NODE"
DO SIZE
+7 DO HEADER
+8 FOR XDRDA=0:0
SET XDRDA=$ORDER(@XDRTMP)
if XDRDA'>0
QUIT
Begin DoDot:1
+9 IF (IOSL-$Y)<6
if IOST["C-"
Begin DoDot:2
+10 WRITE !
SET DIR(0)="E"
DO ^DIR
End DoDot:2
if $DATA(DIRUT)
QUIT
WRITE @IOF,!!
+11 WRITE !,$JUSTIFY(XDRDA,10)
+12 IF XDRSELEC="NO ZERO NODE"
QUIT
+13 SET DR=XDRDR
+14 SET DA=XDRDA
SET DIC=XDRFL
SET DIQ(0)="I"
SET DIQ="XDRX"
KILL XDRX
+15 DO EN^DIQ1
+16 SET X=XDRX(XDRFL,XDRDA,.01,"I")
+17 FOR
if X'["MERGING INTO"
QUIT
SET X=$PIECE(X,"(",2,99)
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+18 WRITE " ",$EXTRACT(X,1,28),?40
+19 FOR I=0:0
SET I=$ORDER(XDRX(XDRFL,XDRDA,I))
if I'>0
QUIT
IF I'=.01
Begin DoDot:2
+20 SET Y=$PIECE(^DD(XDRFL,I,0),U,2)
+21 SET X=XDRX(XDRFL,XDRDA,I,"I")
+22 IF Y["D"
SET N=10
IF X'=""
SET X=$$FMTE^XLFDT(X,"2D")
WRITE $JUSTIFY(X,N)
+23 IF Y'["D"
IF $DATA(NSIZE(I))
SET N=NSIZE(I)+2
WRITE $JUSTIFY(X,N)
End DoDot:2
End DoDot:1
if $DATA(DIRUT)
QUIT
+24 DO ^%ZISC
+25 QUIT
+26 ;
SIZE ;
+1 NEW XDRDA,NC,DR,DA,DIC,DIQ,I,L
+2 SET NC=0
+3 FOR XDRDA=0:0
SET XDRDA=$ORDER(@XDRGLB)
if XDRDA'>0
QUIT
SET NC=NC+1
if NC>50
QUIT
Begin DoDot:1
+4 SET DR=XDRDR
+5 SET DA=XDRDA
SET DIC=XDRFL
SET DIQ(0)="I"
SET DIQ="XDRX"
KILL XDRX
+6 DO EN^DIQ1
+7 FOR I=0:0
SET I=$ORDER(XDRX(XDRFL,XDRDA,I))
if I'>0
QUIT
Begin DoDot:2
+8 SET L=$LENGTH(XDRX(XDRFL,XDRDA,I,"I"))
IF L>$GET(NSIZE(I))
SET NSIZE(I)=L
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
+1 WRITE "LISTING OF ENTRIES IN FILE ",XDRFL," WITH IDENTIFIER OR OTHER PROBLEMS"
+2 WRITE ?10,"SELECTED LISTING: ",XDRSELEC
+3 WRITE !!!,"DATA LISTED ACROSS THE PAGE IN THE FOLLOWING ORDER:",!!,"INTERNAL ENTRY NUMBER"
+4 IF XDRSELEC="NO ZERO NODE"
WRITE !!
QUIT
+5 FOR I=0:0
SET I=$ORDER(NSIZE(I))
if I'>0
QUIT
WRITE !,$PIECE(^DD(XDRFL,I,0),U)
+6 WRITE !!,"XXXXXXXXXX XXXXXXXXXXXXXXXXXXXXXXXXXXX",?40
+7 FOR I=.01:0
SET I=$ORDER(NSIZE(I))
if I'>0
QUIT
Begin DoDot:1
+8 SET X=$PIECE(^DD(XDRFL,I,0),U,2)
IF X["D"
SET NSIZE(I)=8
+9 SET X=$EXTRACT("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX",1,NSIZE(I))
+10 WRITE $JUSTIFY(X,NSIZE(I)+2)
End DoDot:1
+11 WRITE !
+12 QUIT
+13 ;
SELECT ;
+1 NEW NC,N,XDRX,I,DIR,Y
+2 SET NC=0
+3 SET N="A"
FOR
SET N=$ORDER(^XTMP("XDRDPREL",XDRFL,N))
if N=""
QUIT
SET NC=NC+1
SET XDRX(NC)=N
+4 WRITE !!,"Enter the number of the desired list to output:",!
+5 FOR I=0:0
SET I=$ORDER(XDRX(I))
if I'>0
QUIT
WRITE !,$JUSTIFY(I,2)," ",XDRX(I)
+6 WRITE !!
SET DIR(0)="N^1:"_NC
SET DIR("A")="List number"
DO ^DIR
+7 SET XDRSELEC=""
+8 IF Y>0
SET XDRSELEC=XDRX(+Y)
+9 QUIT
+10 ;
EXIT ;
+1 QUIT
