- DDGFORD ;SFISC/MKO-REORDER THE FIELDS ON BLOCK ;07:13 AM 25 May 1994
- ;;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.
- ;
- ;In: DDGFBK = Block number
- ; DDGFPG = Page number
- ; DDGFFM = Form number^Form name
- ; DDGFREF = Global reference
- ;
- EN(DDGFBK) ;
- N DDO,DA,DIK
- N DDGFLN,DDGFLIST,DDGFR,DDGFC,DDGFN,DDGFO
- ;
- D MSG^DDGF("Reordering ...")
- ;Loop through all fields in DDGFREF and put into DDGFLIST array
- S DDO="" F S DDO=$O(@DDGFREF@("F",DDGFPG,DDGFBK,DDO)) Q:DDO="" D
- . S DDGFLN=@DDGFREF@("F",DDGFPG,DDGFBK,DDO)
- . I $P(DDGFLN,U,8)>0 S DDGFLIST(+$P(DDGFLN,U,5),+$P(DDGFLN,U,6),DDO)=""
- . E I $P(DDGFLN,U,4)]"" S DDGFLIST(+$P(DDGFLN,U),+$P(DDGFLN,U,2),DDO)=""
- ;
- K ^DIST(.404,DDGFBK,40,"B")
- S DDGFN=0
- S DDGFR="" F S DDGFR=$O(DDGFLIST(DDGFR)) Q:DDGFR="" D
- . S DDGFC="" F S DDGFC=$O(DDGFLIST(DDGFR,DDGFC)) Q:DDGFC="" D
- .. S DDO="" F S DDO=$O(DDGFLIST(DDGFR,DDGFC,DDO)) Q:DDO="" D
- ... S DDGFN=DDGFN+1
- ... S DDGFO=$P(^DIST(.404,DDGFBK,40,DDO,0),U)
- ... S:DDGFO'=DDGFN $P(^DIST(.404,DDGFBK,40,DDO,0),U)=DDGFN
- ;
- S DIK="^DIST(.404,DDGFBK,40,",DA(1)=DDGFBK,DIK(1)=".01^B"
- D ENALL^DIK
- D MSG^DDGF("Reordering completed.") H 1
- D MSG^DDGF()
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDGFORD 1465 printed Jan 18, 2025@03:43:26 Page 2
- DDGFORD ;SFISC/MKO-REORDER THE FIELDS ON BLOCK ;07:13 AM 25 May 1994
- +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 ;In: DDGFBK = Block number
- +8 ; DDGFPG = Page number
- +9 ; DDGFFM = Form number^Form name
- +10 ; DDGFREF = Global reference
- +11 ;
- EN(DDGFBK) ;
- +1 NEW DDO,DA,DIK
- +2 NEW DDGFLN,DDGFLIST,DDGFR,DDGFC,DDGFN,DDGFO
- +3 ;
- +4 DO MSG^DDGF("Reordering ...")
- +5 ;Loop through all fields in DDGFREF and put into DDGFLIST array
- +6 SET DDO=""
- FOR
- SET DDO=$ORDER(@DDGFREF@("F",DDGFPG,DDGFBK,DDO))
- if DDO=""
- QUIT
- Begin DoDot:1
- +7 SET DDGFLN=@DDGFREF@("F",DDGFPG,DDGFBK,DDO)
- +8 IF $PIECE(DDGFLN,U,8)>0
- SET DDGFLIST(+$PIECE(DDGFLN,U,5),+$PIECE(DDGFLN,U,6),DDO)=""
- +9 IF '$TEST
- IF $PIECE(DDGFLN,U,4)]""
- SET DDGFLIST(+$PIECE(DDGFLN,U),+$PIECE(DDGFLN,U,2),DDO)=""
- End DoDot:1
- +10 ;
- +11 KILL ^DIST(.404,DDGFBK,40,"B")
- +12 SET DDGFN=0
- +13 SET DDGFR=""
- FOR
- SET DDGFR=$ORDER(DDGFLIST(DDGFR))
- if DDGFR=""
- QUIT
- Begin DoDot:1
- +14 SET DDGFC=""
- FOR
- SET DDGFC=$ORDER(DDGFLIST(DDGFR,DDGFC))
- if DDGFC=""
- QUIT
- Begin DoDot:2
- +15 SET DDO=""
- FOR
- SET DDO=$ORDER(DDGFLIST(DDGFR,DDGFC,DDO))
- if DDO=""
- QUIT
- Begin DoDot:3
- +16 SET DDGFN=DDGFN+1
- +17 SET DDGFO=$PIECE(^DIST(.404,DDGFBK,40,DDO,0),U)
- +18 if DDGFO'=DDGFN
- SET $PIECE(^DIST(.404,DDGFBK,40,DDO,0),U)=DDGFN
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +19 ;
- +20 SET DIK="^DIST(.404,DDGFBK,40,"
- SET DA(1)=DDGFBK
- SET DIK(1)=".01^B"
- +21 DO ENALL^DIK
- +22 DO MSG^DDGF("Reordering completed.")
- HANG 1
- +23 DO MSG^DDGF()
- +24 QUIT