Routine: ORULG

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)

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)

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

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

ORULG.m