DIARR4 ;SFISC/DCM-ARCHIVING FUNCTION, FIGURE OUT FG(CONT) ;3/15/93 8:54 AM
;;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.
;
CLEANUP K DIAROSF,DIAROSFN,DIAROBF,DIAROBFN,DIAROFLD,DIAROIDF,DIAROSUB,DIAROLUP
S (DIARTAB,DIAROIDF,DIAROFLD,DIAROLVL)=0
Q
;
LKUP Q:$E(DIAROVAL)'="@"
S DIAROVAL=$G(DIAROAT(DIAROVAL)) I $E(DIAROVAL)="@" G LKUP
S DIAROXX=DIAROX,DIAROX=$P(DIAROX,"=")_"="_DIAROVAL,DIAROBCK=1
Q
;
BKPTR S DIAROLNE="FILE SHIFT (Forward Pointer/Backward Pointer): " D SET^DIARR3
I DIAROX["=@",$G(^TMP("DIAR",$J,DIAROREQ,DIAROM,DIAROZ+1))'["BEGIN:" S DIAROLNE="FILE: "_$P(DIAROX,U)_" (#"_+$P(DIAROX,U,2)_")" D SET^DIARR3 D SFT2
Q
;
SFT2 S DIAROBPT=1,DIAROXX=DIAROX,DIAROX="BEGIN:"_$P(DIAROX,":")_$P(DIAROX,"=",2)
D BEGIN^DIARR3
S DIAROBPT=0
S DIAROX=DIAROXX K DIAROXX
Q
;
POP S DIAROLVL=DIAROLVL-1 S:DIAROLVL=0 DIAROLVL=1
K DIAROSUB(DIAROBFN)
Q
;
BE S DIAROLVL=+$P($P(DIAROX,"=",2),"@",2)
I $P(DIAROX,U)=$P(DIAROSTK(DIAROLVL-1),U) S DIAROSTK(DIAROLVL)=DIAROSTK(DIAROLVL-1)
S DIAROZ=$O(^TMP("DIAR",$J,DIAROREQ,DIAROM,DIAROZ)),DIAROX2=^(DIAROZ)
S DIAROLNE="FIELD NAME: "_$P(DIAROX,U)_" (#"_+$P(DIAROX,U,2)_") = "_$P(DIAROX2,"=",2) D SET^DIARR3
S DIAROLNE="SUBFILE: "_$P(DIAROX,U)_" (#"_$P(DIAROSTK(DIAROLVL),U,2)_") ",DIARTAB=$P(DIAROSTK(DIAROLVL),U,3) D SET^DIARR3
S DIAROLNE="LOOKUP VALUE (#.01): "_$P(DIAROX2,"=",2) D SET^DIARR3
S DIAROLNE="FIELD NAME: "_$P(DIAROX2,U)_" (#"_+$P(DIAROX2,U,2)_") = "_$P(DIAROX2,"=",2),DIARTAB=$P(DIAROSTK(DIAROLVL),U,3)+2 D SET^DIARR3 S DIARTAB=DIARTAB-4
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIARR4 1809 printed Sep 23, 2025@20:21 Page 2
DIARR4 ;SFISC/DCM-ARCHIVING FUNCTION, FIGURE OUT FG(CONT) ;3/15/93 8:54 AM
+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 ;
CLEANUP KILL DIAROSF,DIAROSFN,DIAROBF,DIAROBFN,DIAROFLD,DIAROIDF,DIAROSUB,DIAROLUP
+1 SET (DIARTAB,DIAROIDF,DIAROFLD,DIAROLVL)=0
+2 QUIT
+3 ;
LKUP if $EXTRACT(DIAROVAL)'="@"
QUIT
+1 SET DIAROVAL=$GET(DIAROAT(DIAROVAL))
IF $EXTRACT(DIAROVAL)="@"
GOTO LKUP
+2 SET DIAROXX=DIAROX
SET DIAROX=$PIECE(DIAROX,"=")_"="_DIAROVAL
SET DIAROBCK=1
+3 QUIT
+4 ;
BKPTR SET DIAROLNE="FILE SHIFT (Forward Pointer/Backward Pointer): "
DO SET^DIARR3
+1 IF DIAROX["=@"
IF $GET(^TMP("DIAR",$JOB,DIAROREQ,DIAROM,DIAROZ+1))'["BEGIN:"
SET DIAROLNE="FILE: "_$PIECE(DIAROX,U)_" (#"_+$PIECE(DIAROX,U,2)_")"
DO SET^DIARR3
DO SFT2
+2 QUIT
+3 ;
SFT2 SET DIAROBPT=1
SET DIAROXX=DIAROX
SET DIAROX="BEGIN:"_$PIECE(DIAROX,":")_$PIECE(DIAROX,"=",2)
+1 DO BEGIN^DIARR3
+2 SET DIAROBPT=0
+3 SET DIAROX=DIAROXX
KILL DIAROXX
+4 QUIT
+5 ;
POP SET DIAROLVL=DIAROLVL-1
if DIAROLVL=0
SET DIAROLVL=1
+1 KILL DIAROSUB(DIAROBFN)
+2 QUIT
+3 ;
BE SET DIAROLVL=+$PIECE($PIECE(DIAROX,"=",2),"@",2)
+1 IF $PIECE(DIAROX,U)=$PIECE(DIAROSTK(DIAROLVL-1),U)
SET DIAROSTK(DIAROLVL)=DIAROSTK(DIAROLVL-1)
+2 SET DIAROZ=$ORDER(^TMP("DIAR",$JOB,DIAROREQ,DIAROM,DIAROZ))
SET DIAROX2=^(DIAROZ)
+3 SET DIAROLNE="FIELD NAME: "_$PIECE(DIAROX,U)_" (#"_+$PIECE(DIAROX,U,2)_") = "_$PIECE(DIAROX2,"=",2)
DO SET^DIARR3
+4 SET DIAROLNE="SUBFILE: "_$PIECE(DIAROX,U)_" (#"_$PIECE(DIAROSTK(DIAROLVL),U,2)_") "
SET DIARTAB=$PIECE(DIAROSTK(DIAROLVL),U,3)
DO SET^DIARR3
+5 SET DIAROLNE="LOOKUP VALUE (#.01): "_$PIECE(DIAROX2,"=",2)
DO SET^DIARR3
+6 SET DIAROLNE="FIELD NAME: "_$PIECE(DIAROX2,U)_" (#"_+$PIECE(DIAROX2,U,2)_") = "_$PIECE(DIAROX2,"=",2)
SET DIARTAB=$PIECE(DIAROSTK(DIAROLVL),U,3)+2
DO SET^DIARR3
SET DIARTAB=DIARTAB-4
+7 QUIT
