DIARR3 ;SFISC/DCM-ARCHIVING FUNCTION, FIGURE OUT FG ;3/15/93 7:55 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.
;
Q:'DIARFND U IO(0) W !,"Formatting found records..."
S (DIARTAB,DIAROREQ,DIAROM,DIAROZ,DIARZZ,DIAROIDF,DIAROFLD,DIAROLVL,DIAROBPT,DIAROBFN)=0,DIAROFLD(DIAROLVL)=0 K ^TMP("DIARO",$J)
F S DIAROREQ=$O(^TMP("DIAR",$J,DIAROREQ)) Q:DIAROREQ'>0 F S DIAROM=$O(^TMP("DIAR",$J,DIAROREQ,DIAROM)) Q:DIAROM'>0 D CLEANUP^DIARR4 F S DIAROZ=$O(^TMP("DIAR",$J,DIAROREQ,DIAROM,DIAROZ)) Q:DIAROZ'>0 S DIAROX=^(DIAROZ) D EN
Q
EN Q:DIAROX["$END DAT"!(DIAROX="")
S DIAROX1=$P(DIAROX,":")
I $P(DIAROX,U)="$DAT" S DIAROSF=$P(DIAROX,U,2),DIAROSFN=+$P(DIAROX,U,3),DIAROLNE="ARCHIVE FILE: "_DIAROSF_" (#"_DIAROSFN_")" D SET D SV Q
Q:DIAROX["$END DAT"
EN1 I DIAROX1="BEGIN" D BEGIN D SV Q
I DIAROX1="END" D END D SV Q
I DIAROX1="IDENTIFIER"!(DIAROX1="SPECIFIER")!(DIAROX1="KEY") D ID D SV Q
I $L(DIAROX,U)=3,"AMLD"[$P($P(DIAROX,U,3),"=") G:$P(DIAROX,"=",2)?1"@".N1"E" BE^DIARR4 D F1 I DIAROSFN=+$P(DIAROX,U,2) D SV Q
I DIAROX="^"!(DIAROX=":") D POP^DIARR4 D SV Q
I $E(DIAROX1)="""" S DIAROLNE=$E(DIAROX1,2,$L(DIAROX1)-1) D SET Q
D FLDS
SV S DIAROXPL=DIAROX
Q
BEGIN S DIAROBF=$P($P(DIAROX,U),":",2),DIAROBFN=+$P(DIAROX,U,2),DIARTAB=DIARTAB+2,DIAROLVL=DIAROLVL+1,DIAROSTK(DIAROLVL)=DIAROBF_U_DIAROBFN_U_DIARTAB,DIAROIDF(DIAROLVL)=0,DIAROFLD(DIAROLVL)=0
S DIAROSUB="@"_$P(DIAROX,"@",2),DIAROAT(DIAROSUB)=$S(DIAROXPL["@":"@"_$P(DIAROXPL,"@",2),1:$P(DIAROXPL,"=",2)) I DIAROBPT D SUB Q
I DIAROZ=3 G BEGLN1
I $P(DIAROXPL,U,2)[":" S DIAROLNE="FILE: " D SUB G BEGLN
I $P(DIAROXPL,":")="BEGIN" S DIAROLNE=".01 POINTER TO FILE: " G BEGLN
I $L(DIAROXPL,U)=3,"AMLD"[$P($P(DIAROXPL,U,3),"=") S DIAROLNE="SUBFILE: " D SUB G BEGLN
I $L(DIAROXPL,U)=2 S DIAROLNE="POINTER TO FILE: "
BEGLN S DIAROLNE=DIAROLNE_DIAROBF_" (#"_DIAROBFN_")"
D SET
BEGLN1 I $D(DIAROLUP(DIAROBF)) S DIARTAB=$P(DIAROSTK(DIAROLVL),U,3),DIAROLNE=$P(DIAROLUP(DIAROBF),U) D SET K DIAROLUP(DIAROBF)
Q
SUB S DIAROSUB(DIAROBFN)=1_U_DIARTAB
Q
END S (DIAROIDF(DIAROLVL),DIAROFLD(DIAROLVL))=0,DIAROBF=$P(DIAROSTK(DIAROLVL),U),DIAROBFN=$P(DIAROSTK(DIAROLVL),U,2)
I $D(DIAROSUB(DIAROBFN)) S DIARTAB=DIARTAB-2 Q
S:DIAROLVL'=1 DIAROLVL=DIAROLVL-1
Q
ID I DIAROIDF(DIAROLVL)=0 S DIAROLNE="IDENTIFIERS: ",DIARTAB=+$P(DIAROSTK(DIAROLVL),U,3)+2 D SET S DIAROIDF(DIAROLVL)=1
S DIAROLNE=$P($P(DIAROX,U),":",2)_" (#"_+$P(DIAROX,U,2)_") = "_$P(DIAROX,"=",2),DIARTAB=+$P(DIAROSTK(DIAROLVL),U,3)+4 D SET
Q
FLDS S DIAROBCK=0
I DIAROLVL=1,DIAROFLD(DIAROLVL)=0 S DIAROLNE="FIELDS: ",DIARTAB=+$P(DIAROSTK(DIAROLVL),U,3)+2 D SET S DIAROFLD(DIAROLVL)=1
S (DIAROVAL,DIAROLUP)=$P(DIAROX,"=",2),DIARTAB=$P(DIAROSTK(DIAROLVL),U,3)+4
I $L(DIAROX,U)=3 S DIAROBF1=$P(DIAROX,U,2) I $E(DIAROBF1,$L(DIAROBF1))=":" D BKPTR^DIARR4 Q
I +$P(DIAROX,U,2),DIAROVAL["" S DIAROLNE="FIELD NAME: "_$P(DIAROX,U)_" (#"_+$P(DIAROX,U,2)_") = " D LKUP^DIARR4:$E(DIAROVAL)="@" G:DIAROBCK FLDS
I $D(DIAROSUB)=11 S DIARTAB=$P(DIAROSTK(DIAROLVL),U,3)+2
S DIAROLNE=DIAROLNE_DIAROVAL D SET Q
S:$D(DIAROXX) DIAROX=DIAROXX K DIAROXX
Q
SET S DIAROTAB="" S:DIARTAB $P(DIAROTAB," ",DIARTAB)=" "
S DIARZZ=DIARZZ+1,DIAROLNE=DIAROTAB_DIAROLNE
S ^TMP("DIARO",$J,DIAROREQ,DIAROM,DIARZZ)=DIAROLNE
Q
F1 S DIAROLUP($P(DIAROX,U))="LOOKUP VALUE (#.01): "_$P(DIAROX,"=",2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIARR3 3606 printed Apr 09, 2024@21:55:14 Page 2
DIARR3 ;SFISC/DCM-ARCHIVING FUNCTION, FIGURE OUT FG ;3/15/93 7:55 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 ;
+7 if 'DIARFND
QUIT
USE IO(0)
WRITE !,"Formatting found records..."
+8 SET (DIARTAB,DIAROREQ,DIAROM,DIAROZ,DIARZZ,DIAROIDF,DIAROFLD,DIAROLVL,DIAROBPT,DIAROBFN)=0
SET DIAROFLD(DIAROLVL)=0
KILL ^TMP("DIARO",$JOB)
+9 FOR
SET DIAROREQ=$ORDER(^TMP("DIAR",$JOB,DIAROREQ))
if DIAROREQ'>0
QUIT
FOR
SET DIAROM=$ORDER(^TMP("DIAR",$JOB,DIAROREQ,DIAROM))
if DIAROM'>0
QUIT
DO CLEANUP^DIARR4
FOR
SET DIAROZ=$ORDER(^TMP("DIAR",$JOB,DIAROREQ,DIAROM,DIAROZ))
if DIAROZ'>0
QUIT
SET DIAROX=^(DIAROZ)
DO EN
+10 QUIT
EN if DIAROX["$END DAT"!(DIAROX="")
QUIT
+1 SET DIAROX1=$PIECE(DIAROX,":")
+2 IF $PIECE(DIAROX,U)="$DAT"
SET DIAROSF=$PIECE(DIAROX,U,2)
SET DIAROSFN=+$PIECE(DIAROX,U,3)
SET DIAROLNE="ARCHIVE FILE: "_DIAROSF_" (#"_DIAROSFN_")"
DO SET
DO SV
QUIT
+3 if DIAROX["$END DAT"
QUIT
EN1 IF DIAROX1="BEGIN"
DO BEGIN
DO SV
QUIT
+1 IF DIAROX1="END"
DO END
DO SV
QUIT
+2 IF DIAROX1="IDENTIFIER"!(DIAROX1="SPECIFIER")!(DIAROX1="KEY")
DO ID
DO SV
QUIT
+3 IF $LENGTH(DIAROX,U)=3
IF "AMLD"[$PIECE($PIECE(DIAROX,U,3),"=")
if $PIECE(DIAROX,"=",2)?1"@".N1"E"
GOTO BE^DIARR4
DO F1
IF DIAROSFN=+$PIECE(DIAROX,U,2)
DO SV
QUIT
+4 IF DIAROX="^"!(DIAROX=":")
DO POP^DIARR4
DO SV
QUIT
+5 IF $EXTRACT(DIAROX1)=""""
SET DIAROLNE=$EXTRACT(DIAROX1,2,$LENGTH(DIAROX1)-1)
DO SET
QUIT
+6 DO FLDS
SV SET DIAROXPL=DIAROX
+1 QUIT
BEGIN SET DIAROBF=$PIECE($PIECE(DIAROX,U),":",2)
SET DIAROBFN=+$PIECE(DIAROX,U,2)
SET DIARTAB=DIARTAB+2
SET DIAROLVL=DIAROLVL+1
SET DIAROSTK(DIAROLVL)=DIAROBF_U_DIAROBFN_U_DIARTAB
SET DIAROIDF(DIAROLVL)=0
SET DIAROFLD(DIAROLVL)=0
+1 SET DIAROSUB="@"_$PIECE(DIAROX,"@",2)
SET DIAROAT(DIAROSUB)=$SELECT(DIAROXPL["@":"@"_$PIECE(DIAROXPL,"@",2),1:$PIECE(DIAROXPL,"=",2))
IF DIAROBPT
DO SUB
QUIT
+2 IF DIAROZ=3
GOTO BEGLN1
+3 IF $PIECE(DIAROXPL,U,2)[":"
SET DIAROLNE="FILE: "
DO SUB
GOTO BEGLN
+4 IF $PIECE(DIAROXPL,":")="BEGIN"
SET DIAROLNE=".01 POINTER TO FILE: "
GOTO BEGLN
+5 IF $LENGTH(DIAROXPL,U)=3
IF "AMLD"[$PIECE($PIECE(DIAROXPL,U,3),"=")
SET DIAROLNE="SUBFILE: "
DO SUB
GOTO BEGLN
+6 IF $LENGTH(DIAROXPL,U)=2
SET DIAROLNE="POINTER TO FILE: "
BEGLN SET DIAROLNE=DIAROLNE_DIAROBF_" (#"_DIAROBFN_")"
+1 DO SET
BEGLN1 IF $DATA(DIAROLUP(DIAROBF))
SET DIARTAB=$PIECE(DIAROSTK(DIAROLVL),U,3)
SET DIAROLNE=$PIECE(DIAROLUP(DIAROBF),U)
DO SET
KILL DIAROLUP(DIAROBF)
+1 QUIT
SUB SET DIAROSUB(DIAROBFN)=1_U_DIARTAB
+1 QUIT
END SET (DIAROIDF(DIAROLVL),DIAROFLD(DIAROLVL))=0
SET DIAROBF=$PIECE(DIAROSTK(DIAROLVL),U)
SET DIAROBFN=$PIECE(DIAROSTK(DIAROLVL),U,2)
+1 IF $DATA(DIAROSUB(DIAROBFN))
SET DIARTAB=DIARTAB-2
QUIT
+2 if DIAROLVL'=1
SET DIAROLVL=DIAROLVL-1
+3 QUIT
ID IF DIAROIDF(DIAROLVL)=0
SET DIAROLNE="IDENTIFIERS: "
SET DIARTAB=+$PIECE(DIAROSTK(DIAROLVL),U,3)+2
DO SET
SET DIAROIDF(DIAROLVL)=1
+1 SET DIAROLNE=$PIECE($PIECE(DIAROX,U),":",2)_" (#"_+$PIECE(DIAROX,U,2)_") = "_$PIECE(DIAROX,"=",2)
SET DIARTAB=+$PIECE(DIAROSTK(DIAROLVL),U,3)+4
DO SET
+2 QUIT
FLDS SET DIAROBCK=0
+1 IF DIAROLVL=1
IF DIAROFLD(DIAROLVL)=0
SET DIAROLNE="FIELDS: "
SET DIARTAB=+$PIECE(DIAROSTK(DIAROLVL),U,3)+2
DO SET
SET DIAROFLD(DIAROLVL)=1
+2 SET (DIAROVAL,DIAROLUP)=$PIECE(DIAROX,"=",2)
SET DIARTAB=$PIECE(DIAROSTK(DIAROLVL),U,3)+4
+3 IF $LENGTH(DIAROX,U)=3
SET DIAROBF1=$PIECE(DIAROX,U,2)
IF $EXTRACT(DIAROBF1,$LENGTH(DIAROBF1))=":"
DO BKPTR^DIARR4
QUIT
+4 IF +$PIECE(DIAROX,U,2)
IF DIAROVAL[""
SET DIAROLNE="FIELD NAME: "_$PIECE(DIAROX,U)_" (#"_+$PIECE(DIAROX,U,2)_") = "
if $EXTRACT(DIAROVAL)="@"
DO LKUP^DIARR4
if DIAROBCK
GOTO FLDS
+5 IF $DATA(DIAROSUB)=11
SET DIARTAB=$PIECE(DIAROSTK(DIAROLVL),U,3)+2
+6 SET DIAROLNE=DIAROLNE_DIAROVAL
DO SET
QUIT
+7 if $DATA(DIAROXX)
SET DIAROX=DIAROXX
KILL DIAROXX
+8 QUIT
SET SET DIAROTAB=""
if DIARTAB
SET $PIECE(DIAROTAB," ",DIARTAB)=" "
+1 SET DIARZZ=DIARZZ+1
SET DIAROLNE=DIAROTAB_DIAROLNE
+2 SET ^TMP("DIARO",$JOB,DIAROREQ,DIAROM,DIARZZ)=DIAROLNE
+3 QUIT
F1 SET DIAROLUP($PIECE(DIAROX,U))="LOOKUP VALUE (#.01): "_$PIECE(DIAROX,"=",2)
+1 QUIT
