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 Dec 13, 2024@02:44:52 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
