- DMSQP5 ;SFISC/EZ-DD LISTING USING SQLI ;10/30/97 17:46
- ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDMSQP5 3947 printed Feb 19, 2025@00:21:28 Page 2
- DMSQP5 ;SFISC/EZ-DD LISTING USING SQLI ;10/30/97 17:46
- +1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- 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
