ORULG ; SLC/KER/JVS - COLUMNAR GLOBAL LISTING BY PIECE ;; 08-19-92
;;3.0;ORDER ENTRY/RESULTS REPORTING;**18**;Dec 17, 1997
;
; Variables passed
; ROOT Global file root, i.e., "^XXX(SUB1,SUB2,SUBX,"
; PIE Pieces to display, i.e, "1" or "1^2^4" (Default 1)
; HDR Display title (Default first piece of 0 node)
; COL Number of columns to display (Default 1)
;
EN(ROOT,PIE,HDR,COL) ; Entry Point - device selection not allowed
N X,PRTR S PRTR=0
G INIT
ENP(ROOT,PIE,HDR,COL) ; Entry Point - device selection allowed
N X,PRTR S PRTR=1
;
INIT ;
D HOME^%ZIS N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
NEW CC,CF,CL,CP,CONT,ELE,END,FMTPG,FPG,FREF,IDX,ITEM,LNS,MDY,M2,M3,M4
NEW N0,NLC,NR,NT,PAGES,PGNO,PREF,PNM,POP,PPG,RECNR,RPC,RT,SN,SNODE,TWD,UW
S MDY=$$MDY() W @IOF
VAL ;
S:$E(ROOT,1)'="^" ROOT="^"_ROOT
S ROOT=$S($E(ROOT,$L(ROOT))=",":$E(ROOT,1,($L(ROOT)-1))_")",($E(ROOT,$L(ROOT))'=","&($E(ROOT,$L(ROOT))'=")")):ROOT_")",1:ROOT) I '$D(@ROOT) W !!,"Global ",ROOT," not found",!! G END
I $E(ROOT,$L(ROOT))=")" S ROOT=$P(ROOT,")",1),RT=ROOT_","
S IDX=0,SNODE=ROOT_",0)" S:$O(@SNODE)'?1N.N IDX=1
I IDX S N0=$P(SNODE,",",1,($L(SNODE,",")-2))_",0)"
I 'IDX&(($D(@SNODE)=11)!($D(@SNODE)=1)) S N0=SNODE
I 'IDX&(($D(@SNODE)=10)!($D(@SNODE)=0)) W !,"Not a valid Fileman Global" G END
S:HDR=""&($D(@N0)=1!($D(@N0)=11)) HDR=$P(@N0,"^",1) S:HDR=""&($D(@N0)'=1&($D(@N0)'=11)) HDR="GENERIC LISTING" S HDR=$$UPPER(HDR)
I 'PRTR G START
OPEN ;
K IOP,%ZIS S %ZIS="NQM",%IS("B")="" D ^%ZIS K %ZIS
I POP W !,$C(7),"Terminated. No device specified." G END
S IOP=ION_";"_IOST_$S($D(IO("DOC")):";"_IO("DOC"),1:";"_IOM_";"_IOSL)
I IO=IO(0),"C"[$E(IOST),$D(IO("Q"))#2 G START
I IO'=IO(0),'$D(IO("Q")) W !!,"Queueing report" S IO("Q")=1,ZTDTH=$H
I '$D(IO("Q")) D ^%ZIS G START
S ZTRTN="START^ORULG",ZTIO=IOP,ZTDESC="GLOBAL LISTING (ORULG)"
S (ZTSAVE("ROOT"),ZTSAVE("HDR"),ZTSAVE("RT"),ZTSAVE("N0"),ZTSAVE("PIE"),ZTSAVE("COL"),ZTSAVE("MDY"),ZTSAVE("IDX"))=""
K IO("Q") D ^%ZTLOAD D HOME^%ZIS G END
NY S %="N" D RD Q:"^YyNn"[X
W !,"Enter 'N' or return for NO, 'Y' for YES" G NY
RD R X:DTIME S:X["^" X="^" S X=$E(X_%) Q
START ;
I IOST["C-" W @IOF
S:'$D(COL) COL=1 S:COL=""!(+COL>4)!(+COL=0) COL=1 S NT=((COL*6)+(4*(COL-1))),UW=IOM-NT
F CC=UW:-1 Q:((CC#4=0)&(CC#3=0))
S TWD=(CC/COL)+1,M2=TWD+5,M3=M2+9+TWD,M4=M3+9+TWD
S NR=$P(@N0,"^",$L(@N0,"^")),LNS=IOSL-8,FPG=NR\(COL*LNS),PPG=$S(NR#(COL*LNS)=0:(NR/(COL*LNS))-FPG,1:((NR\(COL*LNS))+1)-FPG)
S RPC=(NR#(COL*LNS))\COL,NLC=(NR#(COL*LNS))#COL,PNM=$S(PIE'["^"&(PIE'=""):1,PIE="":1,1:$L(PIE,"^"))
F CP=1:1:PNM S PREF="PIE"_CP NEW @PREF S @PREF=$S(PNM=1:PIE,1:$P(PIE,"^",CP))
STORE ;
S (PGNO,ITEM,RECNR)=0 F CF=1:1:FPG S PGNO=PGNO+1 D
. F CC=1:1:COL D
. . F CL=1:1:LNS S SN=ROOT_","_RECNR_")" Q:(('IDX)&(+($O(@SN))=0))!((IDX)&($O(@SN)="")) D
. . . S ELE="",RECNR=$O(@SN) D ELE S:+RECNR=0!((+RECNR)'=RECNR) RECNR=$C(34)_RECNR_$C(34)
I PPG S PGNO=PGNO+1 D
. F CC=1:1:COL D
. . F CL=1:1:LNS S SN=ROOT_","_RECNR_")" Q:(('IDX)&(+($O(@SN))=0))!((IDX)&($O(@SN)="")) D
. . . S ELE="",RECNR=$O(@SN) D ELE S:+RECNR=0!((+RECNR)'=RECNR) RECNR=$C(34)_RECNR_$C(34)
CNTRL ;
S (PGNO,ITEM,RECNR)=0,CONT="",END=$S(PPG:FPG+2,1:FPG+1)
F PGNO=1:1:END Q:CONT="^" S:CONT="-" CONT="",PGNO=$S(PGNO<3:1,1:PGNO-2) Q:PGNO=END D CENTER(HDR) S FMTPG=$$PGFMT(PGNO) W !,MDY,?(IOM-($L("PAGE: "_FMTPG))),"PAGE: ",FMTPG,! D D DISP,CONT
. F CC=1:1:IOM W "-" W:CC=IOM !
END ;
I IOST["C-" W @IOF
K ZTSK,IOP,%IS Q
DISP ;
F CL=1:1:LNS D
. W:$D(PAGES(PGNO,1,CL)) !,PAGES(PGNO,1,CL) W:'$D(PAGES(PGNO,1,CL)) ! W:$D(PAGES(PGNO,2,CL)) ?M2,PAGES(PGNO,2,CL)
. W:$D(PAGES(PGNO,3,CL)) ?M3,PAGES(PGNO,3,CL) W:$D(PAGES(PGNO,4,CL)) ?M4,PAGES(PGNO,4,CL)
Q
ELE ;
I IDX S ELE=RECNR
I 'IDX S FREF=$P(SN,",",1,($L(SN,",")-1))_","_RECNR_",0)" F CP=1:1:PNM S PREF="PIE"_CP,ELE=$S($L(ELE)=0:ELE_$P(@FREF,"^",@PREF),1:ELE_" "_$P(@FREF,"^",@PREF))
S ELE=$E(ELE,1,TWD),ITEM=ITEM+1
S PAGES(PGNO,CC,CL)=$S(CC=1:$J(ITEM,4)_" "_ELE,1:" "_$J(ITEM,4)_" "_ELE)
Q
CONT ;
I IOST["P-" W @IOF S CONT="" Q
I PGNO>1 W !!,"Press RETURN to continue ""^"" to Quit, ""-"" for previous page "
E W !!,"Press RETURN to continue ""^"" to Quit "
R CONT:DTIME I '$T!(CONT="^") S CONT="^" Q
W @IOF Q
UPPER(STRING) ;
Q $TR(STRING,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
CENTER(STRING) ;
W:STRING="" ! Q:STRING="" W:IOST["P-" ! W ?($S($L(STRING)#2=0:(IOM\2)-($L(STRING)\2),1:((IOM\2)-1)-($L(STRING)\2))),STRING,! Q
PGFMT(PGNO) ;
S PGNO=$S(((+PGNO<10)&(+PGNO>0)):"00"_+PGNO,((+PGNO<100)&(+PGNO>9)):"0"_+PGNO,(+PGNO>99):+PGNO,1:"---") Q PGNO
MDY() ;
N %,%I,X,MDY D NOW^%DTC S MDY=$$FMTE^XLFDT(X,"5D") Q MDY
;changed for Y2K compliance
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORULG 4814 printed Dec 13, 2024@02:34:28 Page 2
ORULG ; SLC/KER/JVS - COLUMNAR GLOBAL LISTING BY PIECE ;; 08-19-92
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**18**;Dec 17, 1997
+2 ;
+3 ; Variables passed
+4 ; ROOT Global file root, i.e., "^XXX(SUB1,SUB2,SUBX,"
+5 ; PIE Pieces to display, i.e, "1" or "1^2^4" (Default 1)
+6 ; HDR Display title (Default first piece of 0 node)
+7 ; COL Number of columns to display (Default 1)
+8 ;
EN(ROOT,PIE,HDR,COL) ; Entry Point - device selection not allowed
+1 NEW X,PRTR
SET PRTR=0
+2 GOTO INIT
ENP(ROOT,PIE,HDR,COL) ; Entry Point - device selection allowed
+1 NEW X,PRTR
SET PRTR=1
+2 ;
INIT ;
+1 DO HOME^%ZIS
NEW ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+2 NEW CC,CF,CL,CP,CONT,ELE,END,FMTPG,FPG,FREF,IDX,ITEM,LNS,MDY,M2,M3,M4
+3 NEW N0,NLC,NR,NT,PAGES,PGNO,PREF,PNM,POP,PPG,RECNR,RPC,RT,SN,SNODE,TWD,UW
+4 SET MDY=$$MDY()
WRITE @IOF
VAL ;
+1 if $EXTRACT(ROOT,1)'="^"
SET ROOT="^"_ROOT
+2 SET ROOT=$SELECT($EXTRACT(ROOT,$LENGTH(ROOT))=",":$EXTRACT(ROOT,1,($LENGTH(ROOT)-1))_")",($EXTRACT(ROOT,$LENGTH(ROOT))'=","&($EXTRACT(ROOT,$LENGTH(ROOT))'=")")):ROOT_")",1:ROOT)
IF '$DATA(@ROOT)
WRITE !!,"Global ",ROOT," not found",!!
GOTO END
+3 IF $EXTRACT(ROOT,$LENGTH(ROOT))=")"
SET ROOT=$PIECE(ROOT,")",1)
SET RT=ROOT_","
+4 SET IDX=0
SET SNODE=ROOT_",0)"
if $ORDER(@SNODE)'?1N.N
SET IDX=1
+5 IF IDX
SET N0=$PIECE(SNODE,",",1,($LENGTH(SNODE,",")-2))_",0)"
+6 IF 'IDX&(($DATA(@SNODE)=11)!($DATA(@SNODE)=1))
SET N0=SNODE
+7 IF 'IDX&(($DATA(@SNODE)=10)!($DATA(@SNODE)=0))
WRITE !,"Not a valid Fileman Global"
GOTO END
+8 if HDR=""&($DATA(@N0)=1!($DATA(@N0)=11))
SET HDR=$PIECE(@N0,"^",1)
if HDR=""&($DATA(@N0)'=1&($DATA(@N0)'=11))
SET HDR="GENERIC LISTING"
SET HDR=$$UPPER(HDR)
+9 IF 'PRTR
GOTO START
OPEN ;
+1 KILL IOP,%ZIS
SET %ZIS="NQM"
SET %IS("B")=""
DO ^%ZIS
KILL %ZIS
+2 IF POP
WRITE !,$CHAR(7),"Terminated. No device specified."
GOTO END
+3 SET IOP=ION_";"_IOST_$SELECT($DATA(IO("DOC")):";"_IO("DOC"),1:";"_IOM_";"_IOSL)
+4 IF IO=IO(0)
IF "C"[$EXTRACT(IOST)
IF $DATA(IO("Q"))#2
GOTO START
+5 IF IO'=IO(0)
IF '$DATA(IO("Q"))
WRITE !!,"Queueing report"
SET IO("Q")=1
SET ZTDTH=$HOROLOG
+6 IF '$DATA(IO("Q"))
DO ^%ZIS
GOTO START
+7 SET ZTRTN="START^ORULG"
SET ZTIO=IOP
SET ZTDESC="GLOBAL LISTING (ORULG)"
+8 SET (ZTSAVE("ROOT"),ZTSAVE("HDR"),ZTSAVE("RT"),ZTSAVE("N0"),ZTSAVE("PIE"),ZTSAVE("COL"),ZTSAVE("MDY"),ZTSAVE("IDX"))=""
+9 KILL IO("Q")
DO ^%ZTLOAD
DO HOME^%ZIS
GOTO END
NY SET %="N"
DO RD
if "^YyNn"[X
QUIT
+1 WRITE !,"Enter 'N' or return for NO, 'Y' for YES"
GOTO NY
RD READ X:DTIME
if X["^"
SET X="^"
SET X=$EXTRACT(X_%)
QUIT
START ;
+1 IF IOST["C-"
WRITE @IOF
+2 if '$DATA(COL)
SET COL=1
if COL=""!(+COL>4)!(+COL=0)
SET COL=1
SET NT=((COL*6)+(4*(COL-1)))
SET UW=IOM-NT
+3 FOR CC=UW:-1
if ((CC#4=0)&(CC#3=0))
QUIT
+4 SET TWD=(CC/COL)+1
SET M2=TWD+5
SET M3=M2+9+TWD
SET M4=M3+9+TWD
+5 SET NR=$PIECE(@N0,"^",$LENGTH(@N0,"^"))
SET LNS=IOSL-8
SET FPG=NR\(COL*LNS)
SET PPG=$SELECT(NR#(COL*LNS)=0:(NR/(COL*LNS))-FPG,1:((NR\(COL*LNS))+1)-FPG)
+6 SET RPC=(NR#(COL*LNS))\COL
SET NLC=(NR#(COL*LNS))#COL
SET PNM=$SELECT(PIE'["^"&(PIE'=""):1,PIE="":1,1:$LENGTH(PIE,"^"))
+7 FOR CP=1:1:PNM
SET PREF="PIE"_CP
NEW @PREF
SET @PREF=$SELECT(PNM=1:PIE,1:$PIECE(PIE,"^",CP))
STORE ;
+1 SET (PGNO,ITEM,RECNR)=0
FOR CF=1:1:FPG
SET PGNO=PGNO+1
Begin DoDot:1
+2 FOR CC=1:1:COL
Begin DoDot:2
+3 FOR CL=1:1:LNS
SET SN=ROOT_","_RECNR_")"
if (('IDX)&(+($ORDER(@SN))=0))!((IDX)&($ORDER(@SN)=""))
QUIT
Begin DoDot:3
+4 SET ELE=""
SET RECNR=$ORDER(@SN)
DO ELE
if +RECNR=0!((+RECNR)'=RECNR)
SET RECNR=$CHAR(34)_RECNR_$CHAR(34)
End DoDot:3
End DoDot:2
End DoDot:1
+5 IF PPG
SET PGNO=PGNO+1
Begin DoDot:1
+6 FOR CC=1:1:COL
Begin DoDot:2
+7 FOR CL=1:1:LNS
SET SN=ROOT_","_RECNR_")"
if (('IDX)&(+($ORDER(@SN))=0))!((IDX)&($ORDER(@SN)=""))
QUIT
Begin DoDot:3
+8 SET ELE=""
SET RECNR=$ORDER(@SN)
DO ELE
if +RECNR=0!((+RECNR)'=RECNR)
SET RECNR=$CHAR(34)_RECNR_$CHAR(34)
End DoDot:3
End DoDot:2
End DoDot:1
CNTRL ;
+1 SET (PGNO,ITEM,RECNR)=0
SET CONT=""
SET END=$SELECT(PPG:FPG+2,1:FPG+1)
+2 FOR PGNO=1:1:END
if CONT="^"
QUIT
if CONT="-"
SET CONT=""
SET PGNO=$SELECT(PGNO<3:1,1:PGNO-2)
if PGNO=END
QUIT
DO CENTER(HDR)
SET FMTPG=$$PGFMT(PGNO)
WRITE !,MDY,?(IOM-($LENGTH("PAGE: "_FMTPG))),"PAGE: ",FMTPG,!
Begin DoDot:1
+3 FOR CC=1:1:IOM
WRITE "-"
if CC=IOM
WRITE !
End DoDot:1
DO DISP
DO CONT
END ;
+1 IF IOST["C-"
WRITE @IOF
+2 KILL ZTSK,IOP,%IS
QUIT
DISP ;
+1 FOR CL=1:1:LNS
Begin DoDot:1
+2 if $DATA(PAGES(PGNO,1,CL))
WRITE !,PAGES(PGNO,1,CL)
if '$DATA(PAGES(PGNO,1,CL))
WRITE !
if $DATA(PAGES(PGNO,2,CL))
WRITE ?M2,PAGES(PGNO,2,CL)
+3 if $DATA(PAGES(PGNO,3,CL))
WRITE ?M3,PAGES(PGNO,3,CL)
if $DATA(PAGES(PGNO,4,CL))
WRITE ?M4,PAGES(PGNO,4,CL)
End DoDot:1
+4 QUIT
ELE ;
+1 IF IDX
SET ELE=RECNR
+2 IF 'IDX
SET FREF=$PIECE(SN,",",1,($LENGTH(SN,",")-1))_","_RECNR_",0)"
FOR CP=1:1:PNM
SET PREF="PIE"_CP
SET ELE=$SELECT($LENGTH(ELE)=0:ELE_$PIECE(@FREF,"^",@PREF),1:ELE_" "_$PIECE(@FREF,"^",@PREF))
+3 SET ELE=$EXTRACT(ELE,1,TWD)
SET ITEM=ITEM+1
+4 SET PAGES(PGNO,CC,CL)=$SELECT(CC=1:$JUSTIFY(ITEM,4)_" "_ELE,1:" "_$JUSTIFY(ITEM,4)_" "_ELE)
+5 QUIT
CONT ;
+1 IF IOST["P-"
WRITE @IOF
SET CONT=""
QUIT
+2 IF PGNO>1
WRITE !!,"Press RETURN to continue ""^"" to Quit, ""-"" for previous page "
+3 IF '$TEST
WRITE !!,"Press RETURN to continue ""^"" to Quit "
+4 READ CONT:DTIME
IF '$TEST!(CONT="^")
SET CONT="^"
QUIT
+5 WRITE @IOF
QUIT
UPPER(STRING) ;
+1 QUIT $TRANSLATE(STRING,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
CENTER(STRING) ;
+1 if STRING=""
WRITE !
if STRING=""
QUIT
if IOST["P-"
WRITE !
WRITE ?($SELECT($LENGTH(STRING)#2=0:(IOM\2)-($LENGTH(STRING)\2),1:((IOM\2)-1)-($LENGTH(STRING)\2))),STRING,!
QUIT
PGFMT(PGNO) ;
+1 SET PGNO=$SELECT(((+PGNO<10)&(+PGNO>0)):"00"_+PGNO,((+PGNO<100)&(+PGNO>9)):"0"_+PGNO,(+PGNO>99):+PGNO,1:"---")
QUIT PGNO
MDY() ;
+1 NEW %,%I,X,MDY
DO NOW^%DTC
SET MDY=$$FMTE^XLFDT(X,"5D")
QUIT MDY
+2 ;changed for Y2K compliance
