DMSQP5 ;SFISC/EZ-DD LISTING USING SQLI ;10/30/97 17:46
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
EN ; for a single file or number range, display DD information
I '$O(^DMSQ("S",0)) W !?5,"Sorry, SQLI files are empty.",! Q
I $$WAIT^DMSQT1 D Q
. W !?5,"Try later. SQLI is being re-built right now."
D DT^DICRW S DMQ="" D ASK G EXIT:DMQ D ASK1 G EXIT:DMQ
S %ZIS="Q" D ^%ZIS G EXIT:POP
I $D(IO("Q")) D G EXIT
. S ZTRTN="DQ^DMSQP5",ZTSAVE("DMFN")="",ZTSAVE("DMFN1")=""
. D ^%ZTLOAD
D DQ
EXIT D ^%ZISC
K DMFN,DMFN1,DM1,DM2,DMQ
Q
ASK ; select file numbers
W !,"WARNING: REPORT JUST WRITES TO THE SCREEN WITHOUT PAGE BREAKS"
W !," (INTENDED FOR SCREEN CAPTURES) SO PICK ONE TABLE"
W !," OR A SMALL RANGE WHEN TESTING",!
S DM1=$O(^DMSQ("T","C",0)),DM2=$O(^DMSQ("T","C",99999999999),-1)
S DIR(0)="NO^"_DM1_":"_DM2_":999999999",DIR("A")="Starting File Number"
S DIR("?")="Enter the number of the file, e.g. 200 or 1.5215"
S DIR("B")=1.521 D ^DIR S:$D(DIRUT) DMQ=1 K DIR Q:DMQ S DMFN=Y
I '$D(^DMSQ("T","C",DMFN)) W !,"SQLI table not found." G ASK
Q
ASK1 S DIR("B")=DMFN ; default to one file (not a range)
S DIR(0)="NO^"_DM1_":"_DM2_":999999999",DIR("A")=" Ending File Number"
S DIR("?")="Optionally enter a larger number for a range, e.g. 1.5217"
D ^DIR S:$D(DTOUT)!$D(DUOUT) DMQ=1 K DIR Q:DMQ S DMFN1=Y
I '$D(^DMSQ("T","C",DMFN1)) D G ASK1
. W !!?5,"There isn't a table for the file number you've entered."
. W !?5,"(The highest possible number is "_DM2_".)",!
I DMFN1'=DMFN,DMFN1'>DMFN D G ASK1
. W !!?5,"Enter a LARGER number to get a range."
. W !?5,"The highest possible number here is "_DM2_".",!
Q
DQ ; print DD information in file number order
; find file number links (from subfiles or pointers)
U IO
N DMQ,FI,TI,EI,CI,PEI,PI,FEI,FKI
N GBL,PARLNK,LINK,PTRLNK,FLD,FLDGBL,ID,PIECE,EXTRACT,FN,DMSQTMP,TN,EN
S DMQ="",FI=$O(^DMSQ("T","C",DMFN),-1)
F S FI=$O(^DMSQ("T","C",FI)) Q:(DMQ)!(FI>DMFN1)!(FI'>0) D
. S TI=0 F S TI=$O(^DMSQ("T","C",FI,TI)) Q:(DMQ)!(TI'>0) D
.. S TN=$P(^DMSQ("T",TI,0),U,1)
.. S (EI,GBL,PARLNK)=""
.. F S EI=$O(^DMSQ("E","F",TI,"C",EI)) Q:(DMQ)!(EI'>0) D
... D PAGE I $D(DIRUT) S DMQ=1 Q
... D RPT
Q
PAGE ; do page breaks if using a terminal (C-) device
I ($Y+6>IOSL)&(IOST["C-") S DIR(0)="E" D ^DIR K DIR W @IOF
Q
RPT ;
I $P(^DMSQ("E",EI,0),U,2)=14 Q ;exclude wp fields here
;include the subfiles created from wp fields later on
S EN=$P(^DMSQ("E",EI,0),U,1)
S (LINK,PTRLNK,FLD,FLDGBL,ID)=""
S CI=$O(^DMSQ("C","B",EI,""))
S PEI=$O(^DMSQ("E","F",TI,"P",""))
S PI="" F S PI=$O(^DMSQ("P","B",PEI,PI)) Q:PI'>0 D
. I CI=$P(^DMSQ("P",PI,0),U,2) D
.. S GBL=GBL_^DMSQ("C",CI,1)_"{K}",ID=1
S FEI=0 F S FEI=$O(^DMSQ("E","F",TI,"F",FEI)) Q:FEI'>0 D
. S FKI=$O(^DMSQ("F","B",FEI,""))
. I FKI,CI=$P(^DMSQ("F",FKI,0),U,3) D
.. S LINK=$P(^DMSQ("T",$P(^DMSQ("DM",$P(^DMSQ("E",FEI,0),U,2),0),U,4),0),U,7)
.. S:ID PARLNK=LINK S:'ID PTRLNK=LINK
Q:ID D ;just process non-ID columns (regular fields)
. S FLD=$P(^DMSQ("C",CI,0),U,6) I $D(^DMSQ("C",CI,1)) D
.. S FLDGBL=GBL_^DMSQ("C",CI,1)
.. S PIECE=$P(^DMSQ("C",CI,0),U,11)
.. S EXTRACT=$P(^DMSQ("C",CI,0),U,12)_","_$P(^(0),U,13)
.. S:PIECE FLDGBL="$P("_FLDGBL_",U,"_PIECE_")"
.. S:EXTRACT FLDGBL="$E("_FLDGBL_","_EXTRACT_")"
D FIELD^DID(FI,FLD,"","LABEL;TYPE","DMSQTMP")
S FN=$S($D(^DIC(FI)):$P(^(FI,0),U),1:$O(^DD(FI,0,"NM","")))
W !,FI_" "_FN,!?($L(FI)-3),"TBL:"_TN
W !?10,FLD_" "_$G(DMSQTMP("LABEL")),!?($L(FLD)+7),"COL:"_EN
W !?20,$G(DMSQTMP("TYPE"))
W:PTRLNK ?32,"TO: "_PTRLNK
W:PARLNK ?52,"SUBFILE OF: "_PARLNK
W !?20,FLDGBL
Q
DMSQP5 ;SFISC/EZ-DD LISTING USING SQLI ;10/30/97 17:46
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ; for a single file or number range, display DD information
+1 IF '$ORDER(^DMSQ("S",0))
WRITE !?5,"Sorry, SQLI files are empty.",!
QUIT
+2 IF $$WAIT^DMSQT1
Begin DoDot:1
+3 WRITE !?5,"Try later. SQLI is being re-built right now."
End DoDot:1
QUIT
+4 DO DT^DICRW
SET DMQ=""
DO ASK
IF DMQ
GOTO EXIT
DO ASK1
IF DMQ
GOTO EXIT
+5 SET %ZIS="Q"
DO ^%ZIS
IF POP
GOTO EXIT
+6 IF $DATA(IO("Q"))
Begin DoDot:1
+7 SET ZTRTN="DQ^DMSQP5"
SET ZTSAVE("DMFN")=""
SET ZTSAVE("DMFN1")=""
+8 DO ^%ZTLOAD
End DoDot:1
GOTO EXIT
+9 DO DQ
EXIT DO ^%ZISC
+1 KILL DMFN,DMFN1,DM1,DM2,DMQ
+2 QUIT
ASK ; select file numbers
+1 WRITE !,"WARNING: REPORT JUST WRITES TO THE SCREEN WITHOUT PAGE BREAKS"
+2 WRITE !," (INTENDED FOR SCREEN CAPTURES) SO PICK ONE TABLE"
+3 WRITE !," OR A SMALL RANGE WHEN TESTING",!
+4 SET DM1=$ORDER(^DMSQ("T","C",0))
SET DM2=$ORDER(^DMSQ("T","C",99999999999),-1)
+5 SET DIR(0)="NO^"_DM1_":"_DM2_":999999999"
SET DIR("A")="Starting File Number"
+6 SET DIR("?")="Enter the number of the file, e.g. 200 or 1.5215"
+7 SET DIR("B")=1.521
DO ^DIR
IF $DATA(DIRUT)
SET DMQ=1
KILL DIR
IF DMQ
QUIT
SET DMFN=Y
+8 IF '$DATA(^DMSQ("T","C",DMFN))
WRITE !,"SQLI table not found."
GOTO ASK
+9 QUIT
ASK1 ; default to one file (not a range)
SET DIR("B")=DMFN
+1 SET DIR(0)="NO^"_DM1_":"_DM2_":999999999"
SET DIR("A")=" Ending File Number"
+2 SET DIR("?")="Optionally enter a larger number for a range, e.g. 1.5217"
+3 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET DMQ=1
KILL DIR
IF DMQ
QUIT
SET DMFN1=Y
+4 IF '$DATA(^DMSQ("T","C",DMFN1))
Begin DoDot:1
+5 WRITE !!?5,"There isn't a table for the file number you've entered."
+6 WRITE !?5,"(The highest possible number is "_DM2_".)",!
End DoDot:1
GOTO ASK1
+7 IF DMFN1'=DMFN
IF DMFN1'>DMFN
Begin DoDot:1
+8 WRITE !!?5,"Enter a LARGER number to get a range."
+9 WRITE !?5,"The highest possible number here is "_DM2_".",!
End DoDot:1
GOTO ASK1
+10 QUIT
DQ ; print DD information in file number order
+1 ; find file number links (from subfiles or pointers)
+2 USE IO
+3 NEW DMQ,FI,TI,EI,CI,PEI,PI,FEI,FKI
+4 NEW GBL,PARLNK,LINK,PTRLNK,FLD,FLDGBL,ID,PIECE,EXTRACT,FN,DMSQTMP,TN,EN
+5 SET DMQ=""
SET FI=$ORDER(^DMSQ("T","C",DMFN),-1)
+6 FOR
SET FI=$ORDER(^DMSQ("T","C",FI))
IF (DMQ)!(FI>DMFN1)!(FI'>0)
QUIT
Begin DoDot:1
+7 SET TI=0
FOR
SET TI=$ORDER(^DMSQ("T","C",FI,TI))
IF (DMQ)!(TI'>0)
QUIT
Begin DoDot:2
+8 SET TN=$PIECE(^DMSQ("T",TI,0),U,1)
+9 SET (EI,GBL,PARLNK)=""
+10 FOR
SET EI=$ORDER(^DMSQ("E","F",TI,"C",EI))
IF (DMQ)!(EI'>0)
QUIT
Begin DoDot:3
+11 DO PAGE
IF $DATA(DIRUT)
SET DMQ=1
QUIT
+12 DO RPT
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
PAGE ; do page breaks if using a terminal (C-) device
+1 IF ($Y+6>IOSL)&(IOST["C-")
SET DIR(0)="E"
DO ^DIR
KILL DIR
WRITE @IOF
+2 QUIT
RPT ;
+1 ;exclude wp fields here
IF $PIECE(^DMSQ("E",EI,0),U,2)=14
QUIT
+2 ;include the subfiles created from wp fields later on
+3 SET EN=$PIECE(^DMSQ("E",EI,0),U,1)
+4 SET (LINK,PTRLNK,FLD,FLDGBL,ID)=""
+5 SET CI=$ORDER(^DMSQ("C","B",EI,""))
+6 SET PEI=$ORDER(^DMSQ("E","F",TI,"P",""))
+7 SET PI=""
FOR
SET PI=$ORDER(^DMSQ("P","B",PEI,PI))
IF PI'>0
QUIT
Begin DoDot:1
+8 IF CI=$PIECE(^DMSQ("P",PI,0),U,2)
Begin DoDot:2
+9 SET GBL=GBL_^DMSQ("C",CI,1)_"{K}"
SET ID=1
End DoDot:2
End DoDot:1
+10 SET FEI=0
FOR
SET FEI=$ORDER(^DMSQ("E","F",TI,"F",FEI))
IF FEI'>0
QUIT
Begin DoDot:1
+11 SET FKI=$ORDER(^DMSQ("F","B",FEI,""))
+12 IF FKI
IF CI=$PIECE(^DMSQ("F",FKI,0),U,3)
Begin DoDot:2
+13 SET LINK=$PIECE(^DMSQ("T",$PIECE(^DMSQ("DM",$PIECE(^DMSQ("E",FEI,0),U,2),0),U,4),0),U,7)
+14 IF ID
SET PARLNK=LINK
IF 'ID
SET PTRLNK=LINK
End DoDot:2
End DoDot:1
+15 ;just process non-ID columns (regular fields)
IF ID
QUIT
Begin DoDot:1
+16 SET FLD=$PIECE(^DMSQ("C",CI,0),U,6)
IF $DATA(^DMSQ("C",CI,1))
Begin DoDot:2
+17 SET FLDGBL=GBL_^DMSQ("C",CI,1)
+18 SET PIECE=$PIECE(^DMSQ("C",CI,0),U,11)
+19 SET EXTRACT=$PIECE(^DMSQ("C",CI,0),U,12)_","_$PIECE(^(0),U,13)
+20 IF PIECE
SET FLDGBL="$P("_FLDGBL_",U,"_PIECE_")"
+21 IF EXTRACT
SET FLDGBL="$E("_FLDGBL_","_EXTRACT_")"
End DoDot:2
End DoDot:1
+22 DO FIELD^DID(FI,FLD,"","LABEL;TYPE","DMSQTMP")
+23 SET FN=$SELECT($DATA(^DIC(FI)):$PIECE(^(FI,0),U),1:$ORDER(^DD(FI,0,"NM","")))
+24 WRITE !,FI_" "_FN,!?($LENGTH(FI)-3),"TBL:"_TN
+25 WRITE !?10,FLD_" "_$GET(DMSQTMP("LABEL")),!?($LENGTH(FLD)+7),"COL:"_EN
+26 WRITE !?20,$GET(DMSQTMP("TYPE"))
+27 IF PTRLNK
WRITE ?32,"TO: "_PTRLNK
+28 IF PARLNK
WRITE ?52,"SUBFILE OF: "_PARLNK
+29 WRITE !?20,FLDGBL
+30 QUIT
