- 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 Feb 19, 2025@00:11:11 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
