source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORULG.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.6 KB
Line 
1ORULG ; SLC/KER/JVS - COLUMNAR GLOBAL LISTING BY PIECE ;; 08-19-92
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**18**;Dec 17, 1997
3 ;
4 ; Variables passed
5 ; ROOT Global file root, i.e., "^XXX(SUB1,SUB2,SUBX,"
6 ; PIE Pieces to display, i.e, "1" or "1^2^4" (Default 1)
7 ; HDR Display title (Default first piece of 0 node)
8 ; COL Number of columns to display (Default 1)
9 ;
10EN(ROOT,PIE,HDR,COL) ; Entry Point - device selection not allowed
11 N X,PRTR S PRTR=0
12 G INIT
13ENP(ROOT,PIE,HDR,COL) ; Entry Point - device selection allowed
14 N X,PRTR S PRTR=1
15 ;
16INIT ;
17 D HOME^%ZIS N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
18 NEW CC,CF,CL,CP,CONT,ELE,END,FMTPG,FPG,FREF,IDX,ITEM,LNS,MDY,M2,M3,M4
19 NEW N0,NLC,NR,NT,PAGES,PGNO,PREF,PNM,POP,PPG,RECNR,RPC,RT,SN,SNODE,TWD,UW
20 S MDY=$$MDY() W @IOF
21VAL ;
22 S:$E(ROOT,1)'="^" ROOT="^"_ROOT
23 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
24 I $E(ROOT,$L(ROOT))=")" S ROOT=$P(ROOT,")",1),RT=ROOT_","
25 S IDX=0,SNODE=ROOT_",0)" S:$O(@SNODE)'?1N.N IDX=1
26 I IDX S N0=$P(SNODE,",",1,($L(SNODE,",")-2))_",0)"
27 I 'IDX&(($D(@SNODE)=11)!($D(@SNODE)=1)) S N0=SNODE
28 I 'IDX&(($D(@SNODE)=10)!($D(@SNODE)=0)) W !,"Not a valid Fileman Global" G END
29 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)
30 I 'PRTR G START
31OPEN ;
32 K IOP,%ZIS S %ZIS="NQM",%IS("B")="" D ^%ZIS K %ZIS
33 I POP W !,$C(7),"Terminated. No device specified." G END
34 S IOP=ION_";"_IOST_$S($D(IO("DOC")):";"_IO("DOC"),1:";"_IOM_";"_IOSL)
35 I IO=IO(0),"C"[$E(IOST),$D(IO("Q"))#2 G START
36 I IO'=IO(0),'$D(IO("Q")) W !!,"Queueing report" S IO("Q")=1,ZTDTH=$H
37 I '$D(IO("Q")) D ^%ZIS G START
38 S ZTRTN="START^ORULG",ZTIO=IOP,ZTDESC="GLOBAL LISTING (ORULG)"
39 S (ZTSAVE("ROOT"),ZTSAVE("HDR"),ZTSAVE("RT"),ZTSAVE("N0"),ZTSAVE("PIE"),ZTSAVE("COL"),ZTSAVE("MDY"),ZTSAVE("IDX"))=""
40 K IO("Q") D ^%ZTLOAD D HOME^%ZIS G END
41NY S %="N" D RD Q:"^YyNn"[X
42 W !,"Enter 'N' or return for NO, 'Y' for YES" G NY
43RD R X:DTIME S:X["^" X="^" S X=$E(X_%) Q
44START ;
45 I IOST["C-" W @IOF
46 S:'$D(COL) COL=1 S:COL=""!(+COL>4)!(+COL=0) COL=1 S NT=((COL*6)+(4*(COL-1))),UW=IOM-NT
47 F CC=UW:-1 Q:((CC#4=0)&(CC#3=0))
48 S TWD=(CC/COL)+1,M2=TWD+5,M3=M2+9+TWD,M4=M3+9+TWD
49 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)
50 S RPC=(NR#(COL*LNS))\COL,NLC=(NR#(COL*LNS))#COL,PNM=$S(PIE'["^"&(PIE'=""):1,PIE="":1,1:$L(PIE,"^"))
51 F CP=1:1:PNM S PREF="PIE"_CP NEW @PREF S @PREF=$S(PNM=1:PIE,1:$P(PIE,"^",CP))
52STORE ;
53 S (PGNO,ITEM,RECNR)=0 F CF=1:1:FPG S PGNO=PGNO+1 D
54 . F CC=1:1:COL D
55 . . F CL=1:1:LNS S SN=ROOT_","_RECNR_")" Q:(('IDX)&(+($O(@SN))=0))!((IDX)&($O(@SN)="")) D
56 . . . S ELE="",RECNR=$O(@SN) D ELE S:+RECNR=0!((+RECNR)'=RECNR) RECNR=$C(34)_RECNR_$C(34)
57 I PPG S PGNO=PGNO+1 D
58 . F CC=1:1:COL D
59 . . F CL=1:1:LNS S SN=ROOT_","_RECNR_")" Q:(('IDX)&(+($O(@SN))=0))!((IDX)&($O(@SN)="")) D
60 . . . S ELE="",RECNR=$O(@SN) D ELE S:+RECNR=0!((+RECNR)'=RECNR) RECNR=$C(34)_RECNR_$C(34)
61CNTRL ;
62 S (PGNO,ITEM,RECNR)=0,CONT="",END=$S(PPG:FPG+2,1:FPG+1)
63 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
64 . F CC=1:1:IOM W "-" W:CC=IOM !
65END ;
66 I IOST["C-" W @IOF
67 K ZTSK,IOP,%IS Q
68DISP ;
69 F CL=1:1:LNS D
70 . 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)
71 . W:$D(PAGES(PGNO,3,CL)) ?M3,PAGES(PGNO,3,CL) W:$D(PAGES(PGNO,4,CL)) ?M4,PAGES(PGNO,4,CL)
72 Q
73ELE ;
74 I IDX S ELE=RECNR
75 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))
76 S ELE=$E(ELE,1,TWD),ITEM=ITEM+1
77 S PAGES(PGNO,CC,CL)=$S(CC=1:$J(ITEM,4)_" "_ELE,1:" "_$J(ITEM,4)_" "_ELE)
78 Q
79CONT ;
80 I IOST["P-" W @IOF S CONT="" Q
81 I PGNO>1 W !!,"Press RETURN to continue ""^"" to Quit, ""-"" for previous page "
82 E W !!,"Press RETURN to continue ""^"" to Quit "
83 R CONT:DTIME I '$T!(CONT="^") S CONT="^" Q
84 W @IOF Q
85UPPER(STRING) ;
86 Q $TR(STRING,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
87CENTER(STRING) ;
88 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
89PGFMT(PGNO) ;
90 S PGNO=$S(((+PGNO<10)&(+PGNO>0)):"00"_+PGNO,((+PGNO<100)&(+PGNO>9)):"0"_+PGNO,(+PGNO>99):+PGNO,1:"---") Q PGNO
91MDY() ;
92 N %,%I,X,MDY D NOW^%DTC S MDY=$$FMTE^XLFDT(X,"5D") Q MDY
93 ;changed for Y2K compliance
Note: See TracBrowser for help on using the repository browser.