DICL2 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup: Lister, Part 3 ;11JUNE2008
;;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.
;
;.
SCREEN(DIFILE,DIEN,DIFLAGS,DIFIEN,DISCREEN,DINDEX,DI0NODE) ;
;
; return 1 if entry should be screened out
;
S1 ; entries tagged for archiving, or missing the .01 or already on
; the list should be screened out.
;
I DIFILE'<2,'$$VMINUS9^DIEFU(DIFILE,","_DIEN_DIFIEN) Q 1
I $P(DI0NODE,U)="" Q 1
I DIFLAGS[4 N DIREC D I 'DIREC Q 1
. S DIREC=DIEN I DIFLAGS["v" S DIREC=DIREC_";"_$P(DIFILE(DIFILE,"O"),U,2)
. I $D(@DILIST@("B",($E($P(DI0NODE,U),1,DINDEX("MAXSUB"))_"^"_DIREC))) S DIREC=0
. Q
;
S2 ; execute any screen on transformed lookup values
;
N DISKIP S DISKIP=0
I DIFLAGS[4 N DISUB F DISUB=1:1:DINDEX("#") D Q:DISKIP
. N DISCR2 S DISCR2=+$G(DINDEX(DISUB,"FOUND"))
. Q:'$D(DISCREEN(DISUB,DISCR2))
. N DIVAL,D S @DINDEX(DISUB,"GET"),D=DINDEX
. X DISCREEN(DISUB,DISCR2) S DISKIP='$T
. Q
I DISKIP Q DISKIP
N DISCR
S3 ; Additional screening for using an alternate index for loop through file.
I $D(DISCREEN("X")) F DISCR=0:0 S DISCR=$O(DISCREEN("X",DISCR)) Q:'DISCR D Q:DISKIP
. N D,DIPART,DISUB,DIVAL,X
. X DISCREEN("X",DISCR,"GET") I DIVAL="" S DISKIP=1 Q
. F DISUB=0:0 S DISUB=$O(DISCREEN("VAL",DISCR,DISUB)) Q:'DISUB D Q:'DISKIP
. . S D="",DISKIP=1
. . S DIPART=DISCREEN("VAL",DISCR,DISUB) Q:$P(DIVAL,DIPART)'=""
. . S X=$G(DISCREEN("X",DISCR,DISUB)) I X]"" X X Q:'$T
. . S DISKIP=0 Q
. Q
I DISKIP Q DISKIP
S4 ; Execute Screen parameter, whole file screen.
F DISCR="F","S" I $G(DISCREEN(DISCR))'="" D Q:DISKIP
. N %,D S D=$G(DINDEX)
. N DIC S DIC=DIFILE(DIFILE,"O")
. I DIFLAGS[4 S DIC(0)=$TR(DIFLAGS,"2^fqlpqtuv4PQU")
. E S DIC(0)=$TR(DIFLAGS,"2^fpq3BIMPQ")
. N Y M Y=DIEN
. N Y1 S Y1=DIEN_DIFIEN
. N X S X=$G(@DIFILE(DIFILE)@(DIEN,0)),X=$P(X,U)
. I DIFLAGS[4,DIFLAGS["p" N I S I=DIEN
. D
. . N DIFILE,DIXV,DIY,DIYX
. . I 1 X DISCREEN(DISCR) S DISKIP='$T
.
S5 . ; if the screen returned DIERR, id the error's source with a second
. ; error and exit
.
. I $G(DIERR) D
. . S DISKIP=1
. . N DICONTXT
. . S DICONTXT=$S(DISCR["F":"Whole File Screen",1:"Screen Parameter")
. . D ERR^DICF4(120,DIFILE,DIEN,"",DICONTXT)
Q DISKIP
;
ACCEPT(DIFILE,DIEN,DIFLAGS,DIFIEN,DINDEX,DIDENT,DILIST,DI0NODE) ;
; accept an entry into the output list
;
A1 ; if we're doing the final pass (just looking to see if there are any
; more entries), we don't actually add it to the list, just note what
; we found and quit
;
I DIDENT(-1,"JUST LOOKING") D Q
. S DIDENT(-1,"JUST LOOKING")=0
. S DIDENT(-1,"MORE?")=1
. Q:DIFLAGS[4
. N DISAME,I S DISAME=0
. F I=1:1 Q:I>DINDEX("#") D Q:DISAME<I
. . I DIDENT(-1,"LAST",I,"I")'=DINDEX(I) Q
. . S DISAME=I Q
. F I=1:1:(DINDEX("#")+1) K DIDENT(-1,"LAST",I,"I")
. Q:DISAME=DINDEX("#")
. F I=(DISAME+2):1:(DINDEX("#")+1) S DIDENT(-1,"LAST",I)=""
. S DIDENT(-1,"LAST","IEN")="" Q
;
A2 ; increment the number found; if it's the max, we flag to make the
; next pass a final just looking pass
;
S DIDENT(-1)=DIDENT(-1)+1
I DIDENT(-1)=DIDENT(-1,"MAX") D
. S DIDENT(-1,"JUST LOOKING")=1
. Q:DIFLAGS[4
. N I F I=1:1:(DINDEX("#")+1) D
. . S (DIDENT(-1,"LAST",I),DIDENT(-1,"LAST",I,"I"))=DINDEX(I)
. . I I=1,"VP"[DINDEX(I,"TYPE"),'$D(DINDEX("ROOTCNG",1)) S DIDENT(-1,"LAST",I)=DINDEX0(1)
. . Q
. S DIDENT(-1,"LAST")=DIDENT(-1,"LAST",1)
. S DIDENT(-1,"LAST","IEN")=DIEN
. Q
;
A3 ; increment (or decrement) the output list subscript
;
S DILIST("ORDER")=$S(DIFLAGS[4:DIDENT(-1),1:DILIST("ORDER")+DINDEX("WAY"))
N DA M DA=DIEN I '$D(DA(1)) N D0 S D0=DA ;***
;
A4 ; output the specified values of the record
;
I DIFLAGS'["f" D
. D IDS^DICU2(.DIFILE,DIEN_DIFIEN,.DIFLAGS,.DINDEX,DILIST("ORDER"),.DIDENT,DILIST,.DI0NODE)
. Q
Q:DIFLAGS'[4
N DIREC S DIREC=DIEN I DIFLAGS["v" S DIREC=DIREC_";"_$P(DIFILE(DIFILE,"O"),U,2)
I DIFLAGS["f",DIFLAGS'["p" S @DILIST@(DIDENT(-1))=DIREC
S @DILIST@("B",($E($P(DI0NODE,U),1,DINDEX("MAXSUB"))_U_DIREC))=""
Q
;
; Possible output messages
; 202 The input parameter that identifies the |1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICL2 4435 printed Dec 13, 2024@02:46:10 Page 2
DICL2 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup: Lister, Part 3 ;11JUNE2008
+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 ;
+7 ;.
SCREEN(DIFILE,DIEN,DIFLAGS,DIFIEN,DISCREEN,DINDEX,DI0NODE) ;
+1 ;
+2 ; return 1 if entry should be screened out
+3 ;
S1 ; entries tagged for archiving, or missing the .01 or already on
+1 ; the list should be screened out.
+2 ;
+3 IF DIFILE'<2
IF '$$VMINUS9^DIEFU(DIFILE,","_DIEN_DIFIEN)
QUIT 1
+4 IF $PIECE(DI0NODE,U)=""
QUIT 1
+5 IF DIFLAGS[4
NEW DIREC
Begin DoDot:1
+6 SET DIREC=DIEN
IF DIFLAGS["v"
SET DIREC=DIREC_";"_$PIECE(DIFILE(DIFILE,"O"),U,2)
+7 IF $DATA(@DILIST@("B",($EXTRACT($PIECE(DI0NODE,U),1,DINDEX("MAXSUB"))_"^"_DIREC)))
SET DIREC=0
+8 QUIT
End DoDot:1
IF 'DIREC
QUIT 1
+9 ;
S2 ; execute any screen on transformed lookup values
+1 ;
+2 NEW DISKIP
SET DISKIP=0
+3 IF DIFLAGS[4
NEW DISUB
FOR DISUB=1:1:DINDEX("#")
Begin DoDot:1
+4 NEW DISCR2
SET DISCR2=+$GET(DINDEX(DISUB,"FOUND"))
+5 if '$DATA(DISCREEN(DISUB,DISCR2))
QUIT
+6 NEW DIVAL,D
SET @DINDEX(DISUB,"GET")
SET D=DINDEX
+7 XECUTE DISCREEN(DISUB,DISCR2)
SET DISKIP='$TEST
+8 QUIT
End DoDot:1
if DISKIP
QUIT
+9 IF DISKIP
QUIT DISKIP
+10 NEW DISCR
S3 ; Additional screening for using an alternate index for loop through file.
+1 IF $DATA(DISCREEN("X"))
FOR DISCR=0:0
SET DISCR=$ORDER(DISCREEN("X",DISCR))
if 'DISCR
QUIT
Begin DoDot:1
+2 NEW D,DIPART,DISUB,DIVAL,X
+3 XECUTE DISCREEN("X",DISCR,"GET")
IF DIVAL=""
SET DISKIP=1
QUIT
+4 FOR DISUB=0:0
SET DISUB=$ORDER(DISCREEN("VAL",DISCR,DISUB))
if 'DISUB
QUIT
Begin DoDot:2
+5 SET D=""
SET DISKIP=1
+6 SET DIPART=DISCREEN("VAL",DISCR,DISUB)
if $PIECE(DIVAL,DIPART)'=""
QUIT
+7 SET X=$GET(DISCREEN("X",DISCR,DISUB))
IF X]""
XECUTE X
if '$TEST
QUIT
+8 SET DISKIP=0
QUIT
End DoDot:2
if 'DISKIP
QUIT
+9 QUIT
End DoDot:1
if DISKIP
QUIT
+10 IF DISKIP
QUIT DISKIP
S4 ; Execute Screen parameter, whole file screen.
+1 FOR DISCR="F","S"
IF $GET(DISCREEN(DISCR))'=""
Begin DoDot:1
+2 NEW %,D
SET D=$GET(DINDEX)
+3 NEW DIC
SET DIC=DIFILE(DIFILE,"O")
+4 IF DIFLAGS[4
SET DIC(0)=$TRANSLATE(DIFLAGS,"2^fqlpqtuv4PQU")
+5 IF '$TEST
SET DIC(0)=$TRANSLATE(DIFLAGS,"2^fpq3BIMPQ")
+6 NEW Y
MERGE Y=DIEN
+7 NEW Y1
SET Y1=DIEN_DIFIEN
+8 NEW X
SET X=$GET(@DIFILE(DIFILE)@(DIEN,0))
SET X=$PIECE(X,U)
+9 IF DIFLAGS[4
IF DIFLAGS["p"
NEW I
SET I=DIEN
+10 Begin DoDot:2
+11 NEW DIFILE,DIXV,DIY,DIYX
+12 IF 1
XECUTE DISCREEN(DISCR)
SET DISKIP='$TEST
End DoDot:2
+13 S5 ; if the screen returned DIERR, id the error's source with a second
+1 ; error and exit
+2 +3 IF $GET(DIERR)
Begin DoDot:2
+4 SET DISKIP=1
+5 NEW DICONTXT
+6 SET DICONTXT=$SELECT(DISCR["F":"Whole File Screen",1:"Screen Parameter")
+7 DO ERR^DICF4(120,DIFILE,DIEN,"",DICONTXT)
End DoDot:2
End DoDot:1
if DISKIP
QUIT
+8 QUIT DISKIP
+9 ;
ACCEPT(DIFILE,DIEN,DIFLAGS,DIFIEN,DINDEX,DIDENT,DILIST,DI0NODE) ;
+1 ; accept an entry into the output list
+2 ;
A1 ; if we're doing the final pass (just looking to see if there are any
+1 ; more entries), we don't actually add it to the list, just note what
+2 ; we found and quit
+3 ;
+4 IF DIDENT(-1,"JUST LOOKING")
Begin DoDot:1
+5 SET DIDENT(-1,"JUST LOOKING")=0
+6 SET DIDENT(-1,"MORE?")=1
+7 if DIFLAGS[4
QUIT
+8 NEW DISAME,I
SET DISAME=0
+9 FOR I=1:1
if I>DINDEX("#")
QUIT
Begin DoDot:2
+10 IF DIDENT(-1,"LAST",I,"I")'=DINDEX(I)
QUIT
+11 SET DISAME=I
QUIT
End DoDot:2
if DISAME<I
QUIT
+12 FOR I=1:1:(DINDEX("#")+1)
KILL DIDENT(-1,"LAST",I,"I")
+13 if DISAME=DINDEX("#")
QUIT
+14 FOR I=(DISAME+2):1:(DINDEX("#")+1)
SET DIDENT(-1,"LAST",I)=""
+15 SET DIDENT(-1,"LAST","IEN")=""
QUIT
End DoDot:1
QUIT
+16 ;
A2 ; increment the number found; if it's the max, we flag to make the
+1 ; next pass a final just looking pass
+2 ;
+3 SET DIDENT(-1)=DIDENT(-1)+1
+4 IF DIDENT(-1)=DIDENT(-1,"MAX")
Begin DoDot:1
+5 SET DIDENT(-1,"JUST LOOKING")=1
+6 if DIFLAGS[4
QUIT
+7 NEW I
FOR I=1:1:(DINDEX("#")+1)
Begin DoDot:2
+8 SET (DIDENT(-1,"LAST",I),DIDENT(-1,"LAST",I,"I"))=DINDEX(I)
+9 IF I=1
IF "VP"[DINDEX(I,"TYPE")
IF '$DATA(DINDEX("ROOTCNG",1))
SET DIDENT(-1,"LAST",I)=DINDEX0(1)
+10 QUIT
End DoDot:2
+11 SET DIDENT(-1,"LAST")=DIDENT(-1,"LAST",1)
+12 SET DIDENT(-1,"LAST","IEN")=DIEN
+13 QUIT
End DoDot:1
+14 ;
A3 ; increment (or decrement) the output list subscript
+1 ;
+2 SET DILIST("ORDER")=$SELECT(DIFLAGS[4:DIDENT(-1),1:DILIST("ORDER")+DINDEX("WAY"))
+3 ;***
NEW DA
MERGE DA=DIEN
IF '$DATA(DA(1))
NEW D0
SET D0=DA
+4 ;
A4 ; output the specified values of the record
+1 ;
+2 IF DIFLAGS'["f"
Begin DoDot:1
+3 DO IDS^DICU2(.DIFILE,DIEN_DIFIEN,.DIFLAGS,.DINDEX,DILIST("ORDER"),.DIDENT,DILIST,.DI0NODE)
+4 QUIT
End DoDot:1
+5 if DIFLAGS'[4
QUIT
+6 NEW DIREC
SET DIREC=DIEN
IF DIFLAGS["v"
SET DIREC=DIREC_";"_$PIECE(DIFILE(DIFILE,"O"),U,2)
+7 IF DIFLAGS["f"
IF DIFLAGS'["p"
SET @DILIST@(DIDENT(-1))=DIREC
+8 SET @DILIST@("B",($EXTRACT($PIECE(DI0NODE,U),1,DINDEX("MAXSUB"))_U_DIREC))=""
+9 QUIT
+10 ;
+11 ; Possible output messages
+12 ; 202 The input parameter that identifies the |1
+13 ;
