ADEXBLM ; IHS/ADC/GTH - LIST MANAGER API'S ; [ 03/24/1999 8:35 AM ]
;;6.0;ADE;;APRIL 1999
;; ;
DOC ;Documentation APIs for ADEXBLM Generic Display
;This utility uses the Veterans Administration List Manager (VALM)
;
; APIs
;
; FILE^ADEXBLM("Directory","File Name") Displays file indicated
;
; SFILE^ADEXBLM Selection of host file
; for display
;
; VIEWR^ADEXBLM("TAG^ROUTINE","Header") Displays printout of the
; routine. (non - FM, using IO)
; VIEWD^ADEXBLM("Tag^Routine","Header") Displays printout of the
; routine. (FM - using EN1^DIP)
; DIQ^ADEXBLM("DIC","DA") Displays EN1^DIQ for the DIC,DA
; ARRAY^ADEXBLM("array(","Header") Displays the array(..,n,0)
; (%RCR notation)
;
;
EN ; -- main entry point for XB DISPLAY
D EN^VALM("XB DISPLAY")
Q
;
HDR ; -- header code
I XBHDR]"" S VALMHDR(1)=XBHDR
;S VALMHDR(1)="This is a test header for XB DISPLAY."
;S VALMHDR(2)="This is the second line"
Q
;
INIT ; -- init variables and list array
;F LINE=1:1:30 D SET^VALM10(LINE,LINE_" Line number "_LINE)
;S VALMCNT=30
MARKERS ;FHL 9/9/98
;I $G(ADEXBLMMARK) F I=10:10 Q:'$D(@VALMAR@(I)) D
;. F J=10:10:80 D CNTRL^VALM10(I,J,1,IORVON,IORVOFF)
;KILL ADEXBLMMARK
I $G(XBLMMARK) F I=10:10 Q:'$D(@VALMAR@(I)) D
. F J=10:10:80 D CNTRL^VALM10(I,J,1,IORVON,IORVOFF)
KILL XBLMMARK
S VALMCNT=$O(^TMP("ADEXBLM",$J,XBNODE,""),-1)
Q
;
HELP ; -- help code
S X="?"
D DISP^XQORM1
W !!
Q
;
EXIT ; -- exit code
KILL ^TMP("ADEXBLM",$J,XBNODE)
K ;
KILL XBAR,XBDIR,XBFL,XBFN,XBHDR,XBI,XBROU,XBDIR
I '$G(XQORS) D CLEAR^VALM1
Q
;
EXPND ; -- expand code
Q
;
FILE(XBDIR,XBFN) ;PEP pull up a file into the TMP global for display
I '$D(XBHDR) S XBHDR=""
NEW Y,X,I,XBNODE
S XBNODE=$G(XQORS)+1
S Y=$$OPEN^%ZISH(XBDIR,XBFN,"R")
I Y W !,*7,"CANNOT OPEN (OR ACCESS) FILE '",XBDIR,XBFN,"'." S Y=$$DIR^XBDIR("E") G EFILE
KILL ^TMP("ADEXBLM",$J,XBNODE)
F I=1:1 U IO R X:DTIME S X=$$STRIP(X) S ^TMP("ADEXBLM",$J,XBNODE,I,0)=X Q:$$STATUS^%ZISH=-1
D ^%ZISC
;D EN^ADEXBLM
;KILL ^TMP("ADEXBLM",$J,XBNODE)
EFILE ;
Q
;
SFILE ;PEP SELECT FILE
OPEN ;
S IOP="HOME" D ^%ZIS
D DT^DICRW
D ^XBCLS
W !!,"Select a Directory and File",!!
S Y=$$PWD^%ZISH(.XBDIR),XBDIR=XBDIR(1)
KILL DIR
S DIR(0)="F^1:30",DIR("A")="Directory ",DIR("B")=XBDIR
D ^DIR
K DIR
Q:$G(DTOUT)
Q:Y["^"
S XBDIR=Y
FNAME ;
KILL DIR
FNAME1 ;
S DIR(0)="F^1:15",DIR("A")="File Name "
D ^DIR
K DIR
Q:$G(DTOUT)
G:Y["^" OPEN
I Y?.N,$D(XBFL(Y)) S DIR("B")=XBFL(Y) G FNAME1
I Y["*" K XBFL S X=$$LIST^%ZISH(XBDIR,Y,.XBFL) D G FNAME
.F XBI=1:1 Q:'$D(XBFL(XBI)) W !,?5,XBI,?10,XBFL(XBI) I '(XBI#20) R X:DTIME
S XBFN=Y
S X=$$OPEN^%ZISH(XBDIR,XBFN,"R")
ES ;
I X W !,"error on open of file ",XBDIR,XBFN,! K DIR S DIR(0)="E" D ^DIR K DIR Q:Y=1 G FNAME
D ^%ZISC
D FILE^ADEXBLM(XBDIR,XBFN)
ESFILE ;
Q
;
VIEWR(XBROU,XBHDR) ;PEP ** USING XBROU print to a host file for viewing
I '$D(XBHDR) S XBHDR=""
U IO(0)
;D WAIT^DICD
S Y=$$PWD^%ZISH(.XBDIR)
S XBDIR=XBDIR(1)
S XBFN="XB"_$J
S X=$$OPEN^%ZISH(XBDIR,XBFN,"W")
S IOST="P-DEC",IOST(0)=$O(^%ZIS(2,"B","P-DEC",0))
S IOSL=6000
S IOF="#"
S XBIOM=IOM,IOM=80
;S IOF=IOF_",!!,"_""">PAGE MARK<"""_",!!"
;S IOP=IO_";P-DEC;"_IOM_";"_IOSL
;S %ZIS("IOPAR")="("""_XBFN_""":""W"")"
U IO
D @XBROU
D ^%ZISC
D HOME^%ZIS
D FILE^ADEXBLM(XBDIR,XBFN)
S X=$$DEL^%ZISH(XBDIR,XBFN)
KILL XBDIR,XBFN,XBHDR,XBNODE,XBDIR,XBFN
S IOM=XBIOM K XBIOM
Q
;
VIEWD(XBROU) ;PEP ** USING XBROU print to a host file for viewing
U IO(0)
;D WAIT^DICD
S XBFN="XB"_$J
S Y=$$PWD^%ZISH(.XBDIR)
S XBDIR=XBDIR(1)
D DF^%ZISH(.XBDIR)
S X=$$OPEN^%ZISH(XBDIR,XBFN,"W")
S IOP=IO_";P-DEC;"_IOM_";"_IOSL
D ^%ZISC
S IOST="P-DEC",IOST(0)=$O(^%ZIS(2,"B","P-DEC",0))
S IOSL=6000
S IOF="#"
;S IOF=IOF_",!!,"_""">PAGE MARK<"""_",!!"
S %ZIS("IOPAR")="("""_XBDIR_XBFN_""":""W"")"
D @XBROU
D ^%ZISC
D HOME^%ZIS
D FILE^ADEXBLM(XBDIR,XBFN)
S X=$$DEL^%ZISH(XBDIR,XBFN)
KILL XBDIR,XBFN,XBNODE,XBDIR,XBFN
Q
;
DIQ(DIC,DA) ;PEP ** EN^DIQ
S IOSTO=IOST,IOST="P-DEC"
S IOSLO=IOSL,IOSL=6000
I DIC=+DIC S DIC=$$DIC^XBDIQ1(DIC)
I DA'=+DA D PARSE^XBDIQ1(DA)
NEW DIQ,DR
S DIQ(0)="C"
D VIEWR^ADEXBLM("EN^DIQ")
S IOST=IOSTO
KILL IOSTO
S IOSL=IOSLO
KILL IOSLO
KILL XBNODE,XBDIR,XBFN
Q
;
ARRAY(XBAR,XBHDR) ;PEP Display an array that has (...,n,0) structure
I '$D(XBHDR) S XBHDR=""
NEW Y,X,I,XBNODE
S XBNODE=$G(XQORS)+1
KILL ^TMP("ADEXBLM",$J,XBNODE)
S %X=XBAR,%Y="^TMP(""ADEXBLM"","_$J_","_XBNODE_","
D %XY^%RCR
D EN^ADEXBLM
KILL ^TMP("ADEXBLM",$J,XBNODE)
KILL XBNODE,XBDIR,XBFN
ARRAYE ;
Q
;
STRIP(Z) ;REMOVE CONTROLL CHARACTERS
NEW I
F I=1:1:$L(Z) I (32>$A($E(Z,I))) S Z=$E(Z,1,I-1)_" "_$E(Z,I+1,999)
Q Z
;
ADEXBLM ; IHS/ADC/GTH - LIST MANAGER API'S ; [ 03/24/1999 8:35 AM ]
+1 ;;6.0;ADE;;APRIL 1999
+2 ;; ;
DOC ;Documentation APIs for ADEXBLM Generic Display
+1 ;This utility uses the Veterans Administration List Manager (VALM)
+2 ;
+3 ; APIs
+4 ;
+5 ; FILE^ADEXBLM("Directory","File Name") Displays file indicated
+6 ;
+7 ; SFILE^ADEXBLM Selection of host file
+8 ; for display
+9 ;
+10 ; VIEWR^ADEXBLM("TAG^ROUTINE","Header") Displays printout of the
+11 ; routine. (non - FM, using IO)
+12 ; VIEWD^ADEXBLM("Tag^Routine","Header") Displays printout of the
+13 ; routine. (FM - using EN1^DIP)
+14 ; DIQ^ADEXBLM("DIC","DA") Displays EN1^DIQ for the DIC,DA
+15 ; ARRAY^ADEXBLM("array(","Header") Displays the array(..,n,0)
+16 ; (%RCR notation)
+17 ;
+18 ;
EN ; -- main entry point for XB DISPLAY
+1 DO EN^VALM("XB DISPLAY")
+2 QUIT
+3 ;
HDR ; -- header code
+1 IF XBHDR]""
SET VALMHDR(1)=XBHDR
+2 ;S VALMHDR(1)="This is a test header for XB DISPLAY."
+3 ;S VALMHDR(2)="This is the second line"
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 ;F LINE=1:1:30 D SET^VALM10(LINE,LINE_" Line number "_LINE)
+2 ;S VALMCNT=30
MARKERS ;FHL 9/9/98
+1 ;I $G(ADEXBLMMARK) F I=10:10 Q:'$D(@VALMAR@(I)) D
+2 ;. F J=10:10:80 D CNTRL^VALM10(I,J,1,IORVON,IORVOFF)
+3 ;KILL ADEXBLMMARK
+4 IF $GET(XBLMMARK)
FOR I=10:10
IF '$DATA(@VALMAR@(I))
QUIT
Begin DoDot:1
+5 FOR J=10:10:80
DO CNTRL^VALM10(I,J,1,IORVON,IORVOFF)
End DoDot:1
+6 KILL XBLMMARK
+7 SET VALMCNT=$ORDER(^TMP("ADEXBLM",$JOB,XBNODE,""),-1)
+8 QUIT
+9 ;
HELP ; -- help code
+1 SET X="?"
+2 DO DISP^XQORM1
+3 WRITE !!
+4 QUIT
+5 ;
EXIT ; -- exit code
+1 KILL ^TMP("ADEXBLM",$JOB,XBNODE)
K ;
+1 KILL XBAR,XBDIR,XBFL,XBFN,XBHDR,XBI,XBROU,XBDIR
+2 IF '$GET(XQORS)
DO CLEAR^VALM1
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
FILE(XBDIR,XBFN) ;PEP pull up a file into the TMP global for display
+1 IF '$DATA(XBHDR)
SET XBHDR=""
+2 NEW Y,X,I,XBNODE
+3 SET XBNODE=$GET(XQORS)+1
+4 SET Y=$$OPEN^%ZISH(XBDIR,XBFN,"R")
+5 IF Y
WRITE !,*7,"CANNOT OPEN (OR ACCESS) FILE '",XBDIR,XBFN,"'."
SET Y=$$DIR^XBDIR("E")
GOTO EFILE
+6 KILL ^TMP("ADEXBLM",$JOB,XBNODE)
+7 FOR I=1:1
USE IO
READ X:DTIME
SET X=$$STRIP(X)
SET ^TMP("ADEXBLM",$JOB,XBNODE,I,0)=X
IF $$STATUS^%ZISH=-1
QUIT
+8 DO ^%ZISC
+9 ;D EN^ADEXBLM
+10 ;KILL ^TMP("ADEXBLM",$J,XBNODE)
EFILE ;
+1 QUIT
+2 ;
SFILE ;PEP SELECT FILE
OPEN ;
+1 SET IOP="HOME"
DO ^%ZIS
+2 DO DT^DICRW
+3 DO ^XBCLS
+4 WRITE !!,"Select a Directory and File",!!
+5 SET Y=$$PWD^%ZISH(.XBDIR)
SET XBDIR=XBDIR(1)
+6 KILL DIR
+7 SET DIR(0)="F^1:30"
SET DIR("A")="Directory "
SET DIR("B")=XBDIR
+8 DO ^DIR
+9 KILL DIR
+10 IF $GET(DTOUT)
QUIT
+11 IF Y["^"
QUIT
+12 SET XBDIR=Y
FNAME ;
+1 KILL DIR
FNAME1 ;
+1 SET DIR(0)="F^1:15"
SET DIR("A")="File Name "
+2 DO ^DIR
+3 KILL DIR
+4 IF $GET(DTOUT)
QUIT
+5 IF Y["^"
GOTO OPEN
+6 IF Y?.N
IF $DATA(XBFL(Y))
SET DIR("B")=XBFL(Y)
GOTO FNAME1
+7 IF Y["*"
KILL XBFL
SET X=$$LIST^%ZISH(XBDIR,Y,.XBFL)
Begin DoDot:1
+8 FOR XBI=1:1
IF '$DATA(XBFL(XBI))
QUIT
WRITE !,?5,XBI,?10,XBFL(XBI)
IF '(XBI#20)
READ X:DTIME
End DoDot:1
GOTO FNAME
+9 SET XBFN=Y
+10 SET X=$$OPEN^%ZISH(XBDIR,XBFN,"R")
ES ;
+1 IF X
WRITE !,"error on open of file ",XBDIR,XBFN,!
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF Y=1
QUIT
GOTO FNAME
+2 DO ^%ZISC
+3 DO FILE^ADEXBLM(XBDIR,XBFN)
ESFILE ;
+1 QUIT
+2 ;
VIEWR(XBROU,XBHDR) ;PEP ** USING XBROU print to a host file for viewing
+1 IF '$DATA(XBHDR)
SET XBHDR=""
+2 USE IO(0)
+3 ;D WAIT^DICD
+4 SET Y=$$PWD^%ZISH(.XBDIR)
+5 SET XBDIR=XBDIR(1)
+6 SET XBFN="XB"_$JOB
+7 SET X=$$OPEN^%ZISH(XBDIR,XBFN,"W")
+8 SET IOST="P-DEC"
SET IOST(0)=$ORDER(^%ZIS(2,"B","P-DEC",0))
+9 SET IOSL=6000
+10 SET IOF="#"
+11 SET XBIOM=IOM
SET IOM=80
+12 ;S IOF=IOF_",!!,"_""">PAGE MARK<"""_",!!"
+13 ;S IOP=IO_";P-DEC;"_IOM_";"_IOSL
+14 ;S %ZIS("IOPAR")="("""_XBFN_""":""W"")"
+15 USE IO
+16 DO @XBROU
+17 DO ^%ZISC
+18 DO HOME^%ZIS
+19 DO FILE^ADEXBLM(XBDIR,XBFN)
+20 SET X=$$DEL^%ZISH(XBDIR,XBFN)
+21 KILL XBDIR,XBFN,XBHDR,XBNODE,XBDIR,XBFN
+22 SET IOM=XBIOM
KILL XBIOM
+23 QUIT
+24 ;
VIEWD(XBROU) ;PEP ** USING XBROU print to a host file for viewing
+1 USE IO(0)
+2 ;D WAIT^DICD
+3 SET XBFN="XB"_$JOB
+4 SET Y=$$PWD^%ZISH(.XBDIR)
+5 SET XBDIR=XBDIR(1)
+6 DO DF^%ZISH(.XBDIR)
+7 SET X=$$OPEN^%ZISH(XBDIR,XBFN,"W")
+8 SET IOP=IO_";P-DEC;"_IOM_";"_IOSL
+9 DO ^%ZISC
+10 SET IOST="P-DEC"
SET IOST(0)=$ORDER(^%ZIS(2,"B","P-DEC",0))
+11 SET IOSL=6000
+12 SET IOF="#"
+13 ;S IOF=IOF_",!!,"_""">PAGE MARK<"""_",!!"
+14 SET %ZIS("IOPAR")="("""_XBDIR_XBFN_""":""W"")"
+15 DO @XBROU
+16 DO ^%ZISC
+17 DO HOME^%ZIS
+18 DO FILE^ADEXBLM(XBDIR,XBFN)
+19 SET X=$$DEL^%ZISH(XBDIR,XBFN)
+20 KILL XBDIR,XBFN,XBNODE,XBDIR,XBFN
+21 QUIT
+22 ;
DIQ(DIC,DA) ;PEP ** EN^DIQ
+1 SET IOSTO=IOST
SET IOST="P-DEC"
+2 SET IOSLO=IOSL
SET IOSL=6000
+3 IF DIC=+DIC
SET DIC=$$DIC^XBDIQ1(DIC)
+4 IF DA'=+DA
DO PARSE^XBDIQ1(DA)
+5 NEW DIQ,DR
+6 SET DIQ(0)="C"
+7 DO VIEWR^ADEXBLM("EN^DIQ")
+8 SET IOST=IOSTO
+9 KILL IOSTO
+10 SET IOSL=IOSLO
+11 KILL IOSLO
+12 KILL XBNODE,XBDIR,XBFN
+13 QUIT
+14 ;
ARRAY(XBAR,XBHDR) ;PEP Display an array that has (...,n,0) structure
+1 IF '$DATA(XBHDR)
SET XBHDR=""
+2 NEW Y,X,I,XBNODE
+3 SET XBNODE=$GET(XQORS)+1
+4 KILL ^TMP("ADEXBLM",$JOB,XBNODE)
+5 SET %X=XBAR
SET %Y="^TMP(""ADEXBLM"","_$JOB_","_XBNODE_","
+6 DO %XY^%RCR
+7 DO EN^ADEXBLM
+8 KILL ^TMP("ADEXBLM",$JOB,XBNODE)
+9 KILL XBNODE,XBDIR,XBFN
ARRAYE ;
+1 QUIT
+2 ;
STRIP(Z) ;REMOVE CONTROLL CHARACTERS
+1 NEW I
+2 FOR I=1:1:$LENGTH(Z)
IF (32>$ASCII($EXTRACT(Z,I)))
SET Z=$EXTRACT(Z,1,I-1)_" "_$EXTRACT(Z,I+1,999)
+3 QUIT Z
+4 ;
