- DIARR3 ;SFISC/DCM-ARCHIVING FUNCTION, FIGURE OUT FG ;3/15/93 7:55 AM
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- DIARR3 ;SFISC/DCM-ARCHIVING FUNCTION, FIGURE OUT FG ;3/15/93 7:55 AM
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 IF 'DIARFND
- QUIT
- USE IO(0)
- WRITE !,"Formatting found records..."
- +4 SET (DIARTAB,DIAROREQ,DIAROM,DIAROZ,DIARZZ,DIAROIDF,DIAROFLD,DIAROLVL,DIAROBPT,DIAROBFN)=0
- SET DIAROFLD(DIAROLVL)=0
- KILL ^TMP("DIARO",$JOB)
- +5 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
- +6 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
