DIARR6 ;SFISC/DCM-PROCESS ARCHIVED FILE WITH INDEX ;11/18/92 11:49 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.
;
S DIARFILE=$P(DIARL,U,3),DIARFN=+$P(DIARL,U,2)
S DIARREC=$P(DIARL,U,4,99)
F DIARXX=1:1 S DIARFLD=$P(DIARREC,U,DIARXX) Q:DIARFLD="" S DIARFNO=$P(DIARFLD,":"),DIARFNA=$P(DIARFLD,":",2) D
. I +DIARFNO=.01 S DIAR01=DIARFNA
. S DIARPC(DIARXX)=DIARFNO_U_DIARFNA
. S:+DIARFNO'=.01 DIARID(DIARFNO)=DIARFNA_U_DIARFNO
. S DIARCNT=DIARXX
. Q
S DIARCTR=0,DIARFLGT=0
F X DIARX Q:DIARL["$DAT" S DIARCTR=DIARCTR+1 F DIARXX=1:1:DIARCNT S DIARFLD=$P(DIARL,U,DIARXX) S DIARFNA=$P(DIARPC(DIARXX),U,2),DIARFNO=+DIARPC(DIARXX),^TMP("DIARHLP",$J,DIARCTR,DIARFNO)=DIARFNA_" = "_DIARFLD D FLGTH
Q
;
FLGTH S $P(DIARPC(DIARXX),U,3)=$S($L(DIARFLD)>+$P(DIARPC(DIARXX),U,3):$L(DIARFLD),1:+$P(DIARPC(DIARXX),U,3))
Q
;
PROC S DIARIXCT=0 K DIARRF
PROC1 F X DIARX Q:DIARL["$DAT" G PROC1:DIARL["$INDEX" D PROC2 D MATCH^DIARR2 K:'$G(DIARIXX(DIARIXCT)) DIARIXX(DIARIXCT) G PROC1
Q:'$D(DIARIXX)
S (DIARIXCT,DIARXX)=1 D:$G(DIARIXX(DIARIXCT)) FOUND
F S DIARXX=$O(DIARIXX(DIARXX)) Q:DIARXX'>0 D PROC1A
Q
;
PROC1A F X DIARX Q:DIARL["#$#" I DIARL["$DAT" S DIARIXCT=DIARIXCT+1 I DIARIXCT=DIARXX D FOUND Q
Q
;
PROC2 K DIARA S DIARIXCT=DIARIXCT+1,DIARIXX(DIARIXCT)=""
F DIARXX=1:1:DIARCNT S DIARVAL=$P(DIARL,U,DIARXX) D PROC2A
Q
;
PROC2A I +$P(DIARPC(DIARXX),U)=.01 S DIARA(.01)=DIARVAL Q
S DIARA("ID",+$P(DIARPC(DIARXX),U))=DIARVAL
Q
;
FOUND K ^TMP("DIARFG",$J) S DIARZ=1 D SET
F DIARZ=DIARZ+1:1 X DIARX D SET I DIARL["$END DAT" Q
F DIARZ=1:1 S DIARY=$P(DIARIXX(DIARIXCT),",",DIARZ) Q:DIARY="" S DIARRF(DIARY)=$S($D(DIARRF(DIARY)):DIARRF(DIARY)+1,1:0) D SETFG
Q
;
SET S ^TMP("DIARFG",$J,DIARZ)=DIARL
Q
;
SETFG S %X="^TMP(""DIARFG"",$J,",%Y="^TMP(""DIAR"",$J,DIARY,DIARRF(DIARY)," D %XY^%RCR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIARR6 2118 printed Dec 13, 2024@02:44:56 Page 2
DIARR6 ;SFISC/DCM-PROCESS ARCHIVED FILE WITH INDEX ;11/18/92 11:49 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 SET DIARFILE=$PIECE(DIARL,U,3)
SET DIARFN=+$PIECE(DIARL,U,2)
+8 SET DIARREC=$PIECE(DIARL,U,4,99)
+9 FOR DIARXX=1:1
SET DIARFLD=$PIECE(DIARREC,U,DIARXX)
if DIARFLD=""
QUIT
SET DIARFNO=$PIECE(DIARFLD,":")
SET DIARFNA=$PIECE(DIARFLD,":",2)
Begin DoDot:1
+10 IF +DIARFNO=.01
SET DIAR01=DIARFNA
+11 SET DIARPC(DIARXX)=DIARFNO_U_DIARFNA
+12 if +DIARFNO'=.01
SET DIARID(DIARFNO)=DIARFNA_U_DIARFNO
+13 SET DIARCNT=DIARXX
+14 QUIT
End DoDot:1
+15 SET DIARCTR=0
SET DIARFLGT=0
+16 FOR
XECUTE DIARX
if DIARL["$DAT"
QUIT
SET DIARCTR=DIARCTR+1
FOR DIARXX=1:1:DIARCNT
SET DIARFLD=$PIECE(DIARL,U,DIARXX)
SET DIARFNA=$PIECE(DIARPC(DIARXX),U,2)
SET DIARFNO=+DIARPC(DIARXX)
SET ^TMP("DIARHLP",$JOB,DIARCTR,DIARFNO)=DIARFNA_" = "_DIARFLD
DO FLGTH
+17 QUIT
+18 ;
FLGTH SET $PIECE(DIARPC(DIARXX),U,3)=$SELECT($LENGTH(DIARFLD)>+$PIECE(DIARPC(DIARXX),U,3):$LENGTH(DIARFLD),1:+$PIECE(DIARPC(DIARXX),U,3))
+1 QUIT
+2 ;
PROC SET DIARIXCT=0
KILL DIARRF
PROC1 FOR
XECUTE DIARX
if DIARL["$DAT"
QUIT
if DIARL["$INDEX"
GOTO PROC1
DO PROC2
DO MATCH^DIARR2
if '$GET(DIARIXX(DIARIXCT))
KILL DIARIXX(DIARIXCT)
GOTO PROC1
+1 if '$DATA(DIARIXX)
QUIT
+2 SET (DIARIXCT,DIARXX)=1
if $GET(DIARIXX(DIARIXCT))
DO FOUND
+3 FOR
SET DIARXX=$ORDER(DIARIXX(DIARXX))
if DIARXX'>0
QUIT
DO PROC1A
+4 QUIT
+5 ;
PROC1A FOR
XECUTE DIARX
if DIARL["#$#"
QUIT
IF DIARL["$DAT"
SET DIARIXCT=DIARIXCT+1
IF DIARIXCT=DIARXX
DO FOUND
QUIT
+1 QUIT
+2 ;
PROC2 KILL DIARA
SET DIARIXCT=DIARIXCT+1
SET DIARIXX(DIARIXCT)=""
+1 FOR DIARXX=1:1:DIARCNT
SET DIARVAL=$PIECE(DIARL,U,DIARXX)
DO PROC2A
+2 QUIT
+3 ;
PROC2A IF +$PIECE(DIARPC(DIARXX),U)=.01
SET DIARA(.01)=DIARVAL
QUIT
+1 SET DIARA("ID",+$PIECE(DIARPC(DIARXX),U))=DIARVAL
+2 QUIT
+3 ;
FOUND KILL ^TMP("DIARFG",$JOB)
SET DIARZ=1
DO SET
+1 FOR DIARZ=DIARZ+1:1
XECUTE DIARX
DO SET
IF DIARL["$END DAT"
QUIT
+2 FOR DIARZ=1:1
SET DIARY=$PIECE(DIARIXX(DIARIXCT),",",DIARZ)
if DIARY=""
QUIT
SET DIARRF(DIARY)=$SELECT($DATA(DIARRF(DIARY)):DIARRF(DIARY)+1,1:0)
DO SETFG
+3 QUIT
+4 ;
SET SET ^TMP("DIARFG",$JOB,DIARZ)=DIARL
+1 QUIT
+2 ;
SETFG SET %X="^TMP(""DIARFG"",$J,"
SET %Y="^TMP(""DIAR"",$J,DIARY,DIARRF(DIARY),"
DO %XY^%RCR
+1 QUIT
