- 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 Feb 19, 2025@00:05:37 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