DIARR4.m

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 ---DIARR4   1809     printed  Apr 09, 2024@21:43:56                                                                                                                                                                                                      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