- DIARR2 ;SFISC/DCM-ARCHIVING(READ ARCHIVED FG) PROCESS REQUEST ;11/18/92 11:29 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.
- ;
- I $D(DIARIDX) D PROC^DIARR6 G C
- ;
- FG F DIARZ=1:1 X DIARX Q:(DIARL="#$#") S ^TMP("DIARFG",$J,DIARZ)=DIARL D:DIARL="$END DAT" FG1
- C S X=DIARIO X ^DD("FUNC",7,1) K:$D(DIARIO)#2&(DIARIO]"") IO(1,DIARIO)
- D EOP
- Q
- ;
- FG1 F DIARZ=1:1 S DIARFGL=$G(^TMP("DIARFG",$J,DIARZ)) Q:((DIARFGL="$END DAT")!(DIARFGEN)) D FG2
- D IDS
- D MATCH
- D EOP
- Q
- ;
- FG2 Q:$P(DIARFGL,U)="$DAT"
- I DIARNM,$P(DIARFGL,U)=DIARFILE S DIARA(".01")=$P(DIARFGL,"=",2) Q
- I $P(DIARFGL,":")="BEGIN" D FG3 Q
- I $P(DIARFGL,":")="IDENTIFIER" S DIARA("ID",+$P(DIARFGL,U,2))=$P(DIARFGL,"=",2) Q
- I $P(DIARFGL,":")="SPECIFIER" S DIARA("ID",+$P(DIARFGL,U,2))=$P(DIARFGL,"=",2) Q
- I +$P(DIARFGL,U,2)=".01" S DIARA(".01")=$P(DIARFGL,"=",2) S DIARFGEN=1 Q
- Q
- ;
- FG3 Q:+$P(DIARFGL,U,2)=DIARFN
- S DIARF2=+$P(DIARFGL,U,2),DIARZ=DIARZ+1
- F DIARZ=DIARZ:1 S DIARFGL=$G(^TMP("DIARFG",$J,DIARZ)) Q:(($P(DIARFGL,":")="END")&(+$P(DIARFGL,U,2)=DIARF2))
- Q
- ;
- IDS F DIARIDS=0:0 S DIARIDS=$O(DIARID(DIARIDS)) Q:DIARIDS'>0 I '$D(DIARA("ID",DIARIDS)) S DIARA("ID",DIARIDS)=""
- Q
- ;
- MS S DIARMTID="",DIARMT01=0,DIARMTCH=0,DIARIDDN=0,DIARRF(DIARY)=$S($D(DIARRF(DIARY)):DIARRF(DIARY),1:0) Q
- ;
- MATCH F DIARY=0:0 S DIARY=$O(DIARR(DIARY)) Q:DIARY'>0 D MS D:$D(DIARR(DIARY,".01")) MATCH01 D:$D(DIARR(DIARY,"ID")) MATCHID:'DIARIDDN D:DIARMTCH FOUND
- Q
- ;
- MATCH01 Q:DIARR(DIARY,".01")="" Q:DIARA(".01")=""
- I $P(DIARA(".01"),DIARR(DIARY,.01))="" S DIARMT01=1
- I $D(DIARR(DIARY,"ID")) D MATCHID I 'DIARMTID Q
- I DIARMT01 S DIARMTCH=1
- Q
- ;
- MATCHID F DIARZID=0:0 S DIARZID=$O(DIARR(DIARY,"ID",DIARZID)) Q:DIARZID'>0 D MATCHID1 Q:DIARMTID=0
- I DIARMTID,'$D(DIARR(DIARY,".01")) S DIARMTCH=1
- S DIARIDDN=1
- Q
- ;
- MATCHID1 Q:DIARR(DIARY,"ID",DIARZID)="" Q:DIARA("ID",DIARZID)=""
- I $P(DIARA("ID",DIARZID),DIARR(DIARY,"ID",DIARZID))="" S DIARMTID=1 Q
- S DIARMTID=0
- Q
- ;
- FOUND S DIARFND=1
- I $D(DIARIDX) S DIARIXX(DIARIXCT)=DIARIXX(DIARIXCT)_DIARY_"," Q
- S %X="^TMP(""DIARFG"",$J,",%Y="^TMP(""DIAR"",$J,DIARY,DIARRF(DIARY)+1," D %XY^%RCR
- S DIARRF(DIARY)=DIARRF(DIARY)+1
- Q
- ;
- EOP S DIARZ=0,DIARFGEN=0
- K ^TMP("DIARFG",$J),DIARA
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIARR2 2513 printed Feb 19, 2025@00:11:07 Page 2
- DIARR2 ;SFISC/DCM-ARCHIVING(READ ARCHIVED FG) PROCESS REQUEST ;11/18/92 11:29 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 $DATA(DIARIDX)
- DO PROC^DIARR6
- GOTO C
- +8 ;
- FG FOR DIARZ=1:1
- XECUTE DIARX
- if (DIARL="#$#")
- QUIT
- SET ^TMP("DIARFG",$JOB,DIARZ)=DIARL
- if DIARL="$END DAT"
- DO FG1
- C SET X=DIARIO
- XECUTE ^DD("FUNC",7,1)
- if $DATA(DIARIO)#2&(DIARIO]"")
- KILL IO(1,DIARIO)
- +1 DO EOP
- +2 QUIT
- +3 ;
- FG1 FOR DIARZ=1:1
- SET DIARFGL=$GET(^TMP("DIARFG",$JOB,DIARZ))
- if ((DIARFGL="$END DAT")!(DIARFGEN))
- QUIT
- DO FG2
- +1 DO IDS
- +2 DO MATCH
- +3 DO EOP
- +4 QUIT
- +5 ;
- FG2 if $PIECE(DIARFGL,U)="$DAT"
- QUIT
- +1 IF DIARNM
- IF $PIECE(DIARFGL,U)=DIARFILE
- SET DIARA(".01")=$PIECE(DIARFGL,"=",2)
- QUIT
- +2 IF $PIECE(DIARFGL,":")="BEGIN"
- DO FG3
- QUIT
- +3 IF $PIECE(DIARFGL,":")="IDENTIFIER"
- SET DIARA("ID",+$PIECE(DIARFGL,U,2))=$PIECE(DIARFGL,"=",2)
- QUIT
- +4 IF $PIECE(DIARFGL,":")="SPECIFIER"
- SET DIARA("ID",+$PIECE(DIARFGL,U,2))=$PIECE(DIARFGL,"=",2)
- QUIT
- +5 IF +$PIECE(DIARFGL,U,2)=".01"
- SET DIARA(".01")=$PIECE(DIARFGL,"=",2)
- SET DIARFGEN=1
- QUIT
- +6 QUIT
- +7 ;
- FG3 if +$PIECE(DIARFGL,U,2)=DIARFN
- QUIT
- +1 SET DIARF2=+$PIECE(DIARFGL,U,2)
- SET DIARZ=DIARZ+1
- +2 FOR DIARZ=DIARZ:1
- SET DIARFGL=$GET(^TMP("DIARFG",$JOB,DIARZ))
- if (($PIECE(DIARFGL,"
- QUIT
- +3 QUIT
- +4 ;
- IDS FOR DIARIDS=0:0
- SET DIARIDS=$ORDER(DIARID(DIARIDS))
- if DIARIDS'>0
- QUIT
- IF '$DATA(DIARA("ID",DIARIDS))
- SET DIARA("ID",DIARIDS)=""
- +1 QUIT
- +2 ;
- MS SET DIARMTID=""
- SET DIARMT01=0
- SET DIARMTCH=0
- SET DIARIDDN=0
- SET DIARRF(DIARY)=$SELECT($DATA(DIARRF(DIARY)):DIARRF(DIARY),1:0)
- QUIT
- +1 ;
- MATCH FOR DIARY=0:0
- SET DIARY=$ORDER(DIARR(DIARY))
- if DIARY'>0
- QUIT
- DO MS
- if $DATA(DIARR(DIARY,".01"))
- DO MATCH01
- if $DATA(DIARR(DIARY,"ID"))
- if 'DIARIDDN
- DO MATCHID
- if DIARMTCH
- DO FOUND
- +1 QUIT
- +2 ;
- MATCH01 if DIARR(DIARY,".01")=""
- QUIT
- if DIARA(".01")=""
- QUIT
- +1 IF $PIECE(DIARA(".01"),DIARR(DIARY,.01))=""
- SET DIARMT01=1
- +2 IF $DATA(DIARR(DIARY,"ID"))
- DO MATCHID
- IF 'DIARMTID
- QUIT
- +3 IF DIARMT01
- SET DIARMTCH=1
- +4 QUIT
- +5 ;
- MATCHID FOR DIARZID=0:0
- SET DIARZID=$ORDER(DIARR(DIARY,"ID",DIARZID))
- if DIARZID'>0
- QUIT
- DO MATCHID1
- if DIARMTID=0
- QUIT
- +1 IF DIARMTID
- IF '$DATA(DIARR(DIARY,".01"))
- SET DIARMTCH=1
- +2 SET DIARIDDN=1
- +3 QUIT
- +4 ;
- MATCHID1 if DIARR(DIARY,"ID",DIARZID)=""
- QUIT
- if DIARA("ID",DIARZID)=""
- QUIT
- +1 IF $PIECE(DIARA("ID",DIARZID),DIARR(DIARY,"ID",DIARZID))=""
- SET DIARMTID=1
- QUIT
- +2 SET DIARMTID=0
- +3 QUIT
- +4 ;
- FOUND SET DIARFND=1
- +1 IF $DATA(DIARIDX)
- SET DIARIXX(DIARIXCT)=DIARIXX(DIARIXCT)_DIARY_","
- QUIT
- +2 SET %X="^TMP(""DIARFG"",$J,"
- SET %Y="^TMP(""DIAR"",$J,DIARY,DIARRF(DIARY)+1,"
- DO %XY^%RCR
- +3 SET DIARRF(DIARY)=DIARRF(DIARY)+1
- +4 QUIT
- +5 ;
- EOP SET DIARZ=0
- SET DIARFGEN=0
- +1 KILL ^TMP("DIARFG",$JOB),DIARA
- +2 QUIT
