- DDGFLOAD ;SFISC/MKO-LOAD PAGE/BLOCK ;12:33 PM 29 Mar 1995
- ;;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.
- ;
- PG(S,P,V,R) ;
- ;Load and paint page
- ;Called when a new form or page is selected
- ;If Page is not pop-up close all windows first
- ;Input:
- ; S = internal form number
- ; P = internal page number
- ; V = 1 if buffer should be updated but nothing painted
- ; (new windows are still given focus)
- ; R = 1 to reload blocks/fields on page even if loaded before
- ;Returns:
- ; DDGFWID = Window number for a given page
- ; DDGFWIDB = Window number of block displayer for a given page
- ; DDGFLIM = Boundaries within which cursor can be moved
- ;
- I $D(^DIST(.403,+$G(S),40,+$G(P),0))[0 S DDGFWID="P0",DDGFWIDB="B0",DDGFLIM="0^0^"_(IOSL-8)_U_(IOM-2),DDGFPG=0 Q
- ;
- S DDGFWID="P"_DDGFPG,DDGFWIDB="B"_DDGFPG
- I $$EXIST^DDGLIBW(DDGFWID),$G(R) D DESTROY^DDGLIBW(DDGFWID,1)
- I $$EXIST^DDGLIBW(DDGFWID),'$G(R) D Q
- . S DDGFLIM=$P(@DDGFREF@("F",P),U,1,4)
- . I $P(DDGFLIM,U,3,4)?."^" D
- .. S $P(DDGFLIM,U,3,4)=IOSL-8_U_(IOM-2)
- .. D CLOSEALL^DDGLIBW($G(V))
- . D FOCUS^DDGLIBW(DDGFWID,$G(V))
- ;
- N P1,P2,P3,P4,B,B1,B2
- ;
- ;Get page coordinates
- I $D(@DDGFREF@("F",+P))#2 D
- . N N
- . S N=@DDGFREF@("F",+P)
- . S P1=$P(N,U),P2=$P(N,U,2),P3=$P(N,U,3),P4=$P(N,U,4)
- E D
- . S P2=$P(^DIST(.403,+S,40,+P,0),U,3),P3=$P(^(0),U,7)
- . S P1=$P(P2,",")-1,P2=$P(P2,",",2)-1
- . S:P1<0 P1=0 S:P2<0 P2=0
- . S:P3]"" P4=$P(P3,",",2)-1,P3=$P(P3,",")-1
- . S @DDGFREF@("F",P)=P1_U_P2_U_$S(P3]"":P3_U_P4,1:U)_U_$P($G(^DIST(.403,+S,40,+P,1)),U)_U_$P(^(0),U)
- ;
- I P3]"" D
- . S DDGFLIM=P1_U_P2_U_P3_U_P4
- . D CREATE^DDGLIBW(DDGFWID,P1_U_P2_U_(P3-P1+1)_U_(P4-P2+1),1,$G(V))
- . S @DDGFREF@("RC",DDGFWID,P1,P2,P4,"P","P","PTOP")=""
- . S @DDGFREF@("RC",DDGFWID,P3,P4,P4,"P","P","PBRC")=""
- ;
- E D
- . S DDGFLIM=P1_U_P2_U_(IOSL-8)_U_(IOM-2)
- . D CLOSEALL^DDGLIBW($G(V))
- . D CREATE^DDGLIBW(DDGFWID,P1_U_P2_U_(IOSL-7-P1)_U_(IOM-1-P2),"",$G(V))
- ;
- ;Load header block
- S B=$P(^DIST(.403,+S,40,+P,0),U,2) I B]"" D
- . S B1=P1,B2=P2
- . D BK(+P,B,P1,P2,B1,B2,1,$G(V))
- ;
- ;Load all other blocks
- S B=0 F S B=$O(^DIST(.403,+S,40,+P,40,B)) Q:B'=+$P(B,"E") D
- . Q:$D(^DIST(.403,+S,40,+P,40,B,0))[0
- . S B2=$P(^DIST(.403,+S,40,+P,40,B,0),U,3)
- . S B1=$P(B2,",")-1,B2=$P(B2,",",2)-1
- . S:B1<0 B1=0 S:B2<0 B2=0
- . S B1=B1+P1,B2=B2+P2
- . D BK(+P,B,P1,P2,B1,B2,"",$G(V))
- Q
- ;
- BK(P,B,P1,P2,B1,B2,H,V) ;Load block image
- ; P = internal page number
- ; B = internal block number
- ; P1 = page $Y
- ; P2 = page $X
- ; B1 = block abs $Y
- ; B2 = block abs $X
- ; H = 1 if header block, immobile (optional)
- ; V = 1 if buffer should be updated but nothing painted (optional)
- N B3,F,F1,C,C1,C2,C3,D1,D2,D3,I,L,N,T
- Q:$D(^DIST(.404,B,0))[0
- ;
- S N=$P(^DIST(.404,B,0),U)
- S:$G(H) B1=P1,B2=P2
- S B3=B2+$L(N)-1
- S @DDGFREF@("F",P,B)=B1_U_B2_U_B3_U_N
- S @DDGFREF@("BKRC",DDGFWIDB,B1,B2,B3,B)=$S($G(H):"H",1:"")
- ;
- S F1=""
- F S F1=$O(^DIST(.404,B,40,"B",F1)) Q:F1="" S F=$O(^(F1,"")) D:F
- . Q:$D(^DIST(.404,B,40,F,0))[0
- . S C=$P(^DIST(.404,B,40,F,0),U,2),C2=$P($G(^(2)),U,3)
- . I C]"",'$P($G(^DIST(.404,B,40,F,2)),U,4),$P(^(0),U,3)'=1 S C=C_":"
- . S L=$P($G(^DIST(.404,B,40,F,2)),U,2),D2=$P($G(^(2)),U)
- . S T=$P(^DIST(.404,B,40,F,0),U,3)
- . ;
- . ;Kill nodes that are null or contain only ^s
- . S I=0
- . F S I=$O(^DIST(.404,B,40,F,I)) Q:'I I $D(^(I))=1,^(I)?."^" K ^(I)
- . ;
- . ;Check that fields with captions have caption coords
- . I C]"",'C2 S C2="1,1",$P(^DIST(.404,B,40,F,2),U,3)=C2
- . ;
- . ;Check for DD fields that should be Caption fields
- . I T=3,$D(^DIST(.404,B,40,F,1))[0,'$O(^(2)) D
- .. S T=1,(D2,L)=""
- .. S C=$P($G(^DIST(.404,B,40,F,0)),U,2)
- .. S $P(^DIST(.404,B,40,F,0),U,3)=1
- .. S $P(^DIST(.404,B,40,F,2),U,1,4)="^^"_C2_"^"
- . ;
- . ;Check that fields have some coordinate
- . I 'C2,T=1!'D2 D
- .. I C="" D
- ... S C="** Null **",$P(^DIST(.404,B,40,F,0),U,2)=C,$P(^(2),U,4)=""
- ... S:T'=1 C=C_":"
- .. S C2="1,1",$P(^DIST(.404,B,40,F,2),U,3)=C2
- . ;
- . ;Make sure nonCaption fields have data coordinates and length
- . I T'=1 D
- .. S:'D2 D2=+C2_","_($P(C2,",",2)+$L(C)+1),$P(^DIST(.404,B,40,F,2),U)=D2
- .. S:'L L=1,$P(^DIST(.404,B,40,F,2),U,2)=1
- .. I C="",C2 S C2="",$P(^DIST(.404,B,40,F,2),U,3)=""
- . ;
- . I C]"" D
- .. S C1=$P(C2,",")-1+B1,C2=$P(C2,",",2)-1+B2,C3=C2+$L(C)-1
- .. S @DDGFREF@("F",P,B,F)=C1_U_C2_U_C3_U_C
- .. S @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")=""
- .. D WRITE^DDGLIBW(DDGFWID,C,C1-P1,C2-P2,"",$G(V))
- . ;
- . ;NonCaption fields
- . I T'=1 D
- .. S D1=$P(D2,",")-1+B1,D2=$P(D2,",",2)-1+B2,D3=D2+L-1
- .. S $P(@DDGFREF@("F",P,B,F),U,5,8)=D1_U_D2_U_D3_U_L
- .. S @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")=""
- .. D WRITE^DDGLIBW(DDGFWID,$TR($J("",L)," ","_"),D1-P1,D2-P2,"",$G(V))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDGFLOAD 5045 printed Feb 19, 2025@00:08:41 Page 2
- DDGFLOAD ;SFISC/MKO-LOAD PAGE/BLOCK ;12:33 PM 29 Mar 1995
- +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 ;
- PG(S,P,V,R) ;
- +1 ;Load and paint page
- +2 ;Called when a new form or page is selected
- +3 ;If Page is not pop-up close all windows first
- +4 ;Input:
- +5 ; S = internal form number
- +6 ; P = internal page number
- +7 ; V = 1 if buffer should be updated but nothing painted
- +8 ; (new windows are still given focus)
- +9 ; R = 1 to reload blocks/fields on page even if loaded before
- +10 ;Returns:
- +11 ; DDGFWID = Window number for a given page
- +12 ; DDGFWIDB = Window number of block displayer for a given page
- +13 ; DDGFLIM = Boundaries within which cursor can be moved
- +14 ;
- +15 IF $DATA(^DIST(.403,+$GET(S),40,+$GET(P),0))[0
- SET DDGFWID="P0"
- SET DDGFWIDB="B0"
- SET DDGFLIM="0^0^"_(IOSL-8)_U_(IOM-2)
- SET DDGFPG=0
- QUIT
- +16 ;
- +17 SET DDGFWID="P"_DDGFPG
- SET DDGFWIDB="B"_DDGFPG
- +18 IF $$EXIST^DDGLIBW(DDGFWID)
- IF $GET(R)
- DO DESTROY^DDGLIBW(DDGFWID,1)
- +19 IF $$EXIST^DDGLIBW(DDGFWID)
- IF '$GET(R)
- Begin DoDot:1
- +20 SET DDGFLIM=$PIECE(@DDGFREF@("F",P),U,1,4)
- +21 IF $PIECE(DDGFLIM,U,3,4)?."^"
- Begin DoDot:2
- +22 SET $PIECE(DDGFLIM,U,3,4)=IOSL-8_U_(IOM-2)
- +23 DO CLOSEALL^DDGLIBW($GET(V))
- End DoDot:2
- +24 DO FOCUS^DDGLIBW(DDGFWID,$GET(V))
- End DoDot:1
- QUIT
- +25 ;
- +26 NEW P1,P2,P3,P4,B,B1,B2
- +27 ;
- +28 ;Get page coordinates
- +29 IF $DATA(@DDGFREF@("F",+P))#2
- Begin DoDot:1
- +30 NEW N
- +31 SET N=@DDGFREF@("F",+P)
- +32 SET P1=$PIECE(N,U)
- SET P2=$PIECE(N,U,2)
- SET P3=$PIECE(N,U,3)
- SET P4=$PIECE(N,U,4)
- End DoDot:1
- +33 IF '$TEST
- Begin DoDot:1
- +34 SET P2=$PIECE(^DIST(.403,+S,40,+P,0),U,3)
- SET P3=$PIECE(^(0),U,7)
- +35 SET P1=$PIECE(P2,",")-1
- SET P2=$PIECE(P2,",",2)-1
- +36 if P1<0
- SET P1=0
- if P2<0
- SET P2=0
- +37 if P3]""
- SET P4=$PIECE(P3,",",2)-1
- SET P3=$PIECE(P3,",")-1
- +38 SET @DDGFREF@("F",P)=P1_U_P2_U_$SELECT(P3]"":P3_U_P4,1:U)_U_$PIECE($GET(^DIST(.403,+S,40,+P,1)),U)_U_$PIECE(^(0),U)
- End DoDot:1
- +39 ;
- +40 IF P3]""
- Begin DoDot:1
- +41 SET DDGFLIM=P1_U_P2_U_P3_U_P4
- +42 DO CREATE^DDGLIBW(DDGFWID,P1_U_P2_U_(P3-P1+1)_U_(P4-P2+1),1,$GET(V))
- +43 SET @DDGFREF@("RC",DDGFWID,P1,P2,P4,"P","P","PTOP")=""
- +44 SET @DDGFREF@("RC",DDGFWID,P3,P4,P4,"P","P","PBRC")=""
- End DoDot:1
- +45 ;
- +46 IF '$TEST
- Begin DoDot:1
- +47 SET DDGFLIM=P1_U_P2_U_(IOSL-8)_U_(IOM-2)
- +48 DO CLOSEALL^DDGLIBW($GET(V))
- +49 DO CREATE^DDGLIBW(DDGFWID,P1_U_P2_U_(IOSL-7-P1)_U_(IOM-1-P2),"",$GET(V))
- End DoDot:1
- +50 ;
- +51 ;Load header block
- +52 SET B=$PIECE(^DIST(.403,+S,40,+P,0),U,2)
- IF B]""
- Begin DoDot:1
- +53 SET B1=P1
- SET B2=P2
- +54 DO BK(+P,B,P1,P2,B1,B2,1,$GET(V))
- End DoDot:1
- +55 ;
- +56 ;Load all other blocks
- +57 SET B=0
- FOR
- SET B=$ORDER(^DIST(.403,+S,40,+P,40,B))
- if B'=+$PIECE(B,"E")
- QUIT
- Begin DoDot:1
- +58 if $DATA(^DIST(.403,+S,40,+P,40,B,0))[0
- QUIT
- +59 SET B2=$PIECE(^DIST(.403,+S,40,+P,40,B,0),U,3)
- +60 SET B1=$PIECE(B2,",")-1
- SET B2=$PIECE(B2,",",2)-1
- +61 if B1<0
- SET B1=0
- if B2<0
- SET B2=0
- +62 SET B1=B1+P1
- SET B2=B2+P2
- +63 DO BK(+P,B,P1,P2,B1,B2,"",$GET(V))
- End DoDot:1
- +64 QUIT
- +65 ;
- BK(P,B,P1,P2,B1,B2,H,V) ;Load block image
- +1 ; P = internal page number
- +2 ; B = internal block number
- +3 ; P1 = page $Y
- +4 ; P2 = page $X
- +5 ; B1 = block abs $Y
- +6 ; B2 = block abs $X
- +7 ; H = 1 if header block, immobile (optional)
- +8 ; V = 1 if buffer should be updated but nothing painted (optional)
- +9 NEW B3,F,F1,C,C1,C2,C3,D1,D2,D3,I,L,N,T
- +10 if $DATA(^DIST(.404,B,0))[0
- QUIT
- +11 ;
- +12 SET N=$PIECE(^DIST(.404,B,0),U)
- +13 if $GET(H)
- SET B1=P1
- SET B2=P2
- +14 SET B3=B2+$LENGTH(N)-1
- +15 SET @DDGFREF@("F",P,B)=B1_U_B2_U_B3_U_N
- +16 SET @DDGFREF@("BKRC",DDGFWIDB,B1,B2,B3,B)=$SELECT($GET(H):"H",1:"")
- +17 ;
- +18 SET F1=""
- +19 FOR
- SET F1=$ORDER(^DIST(.404,B,40,"B",F1))
- if F1=""
- QUIT
- SET F=$ORDER(^(F1,""))
- if F
- Begin DoDot:1
- +20 if $DATA(^DIST(.404,B,40,F,0))[0
- QUIT
- +21 SET C=$PIECE(^DIST(.404,B,40,F,0),U,2)
- SET C2=$PIECE($GET(^(2)),U,3)
- +22 IF C]""
- IF '$PIECE($GET(^DIST(.404,B,40,F,2)),U,4)
- IF $PIECE(^(0),U,3)'=1
- SET C=C_":"
- +23 SET L=$PIECE($GET(^DIST(.404,B,40,F,2)),U,2)
- SET D2=$PIECE($GET(^(2)),U)
- +24 SET T=$PIECE(^DIST(.404,B,40,F,0),U,3)
- +25 ;
- +26 ;Kill nodes that are null or contain only ^s
- +27 SET I=0
- +28 FOR
- SET I=$ORDER(^DIST(.404,B,40,F,I))
- if 'I
- QUIT
- IF $DATA(^(I))=1
- IF ^(I)?."^"
- KILL ^(I)
- +29 ;
- +30 ;Check that fields with captions have caption coords
- +31 IF C]""
- IF 'C2
- SET C2="1,1"
- SET $PIECE(^DIST(.404,B,40,F,2),U,3)=C2
- +32 ;
- +33 ;Check for DD fields that should be Caption fields
- +34 IF T=3
- IF $DATA(^DIST(.404,B,40,F,1))[0
- IF '$ORDER(^(2))
- Begin DoDot:2
- +35 SET T=1
- SET (D2,L)=""
- +36 SET C=$PIECE($GET(^DIST(.404,B,40,F,0)),U,2)
- +37 SET $PIECE(^DIST(.404,B,40,F,0),U,3)=1
- +38 SET $PIECE(^DIST(.404,B,40,F,2),U,1,4)="^^"_C2_"^"
- End DoDot:2
- +39 ;
- +40 ;Check that fields have some coordinate
- +41 IF 'C2
- IF T=1!'D2
- Begin DoDot:2
- +42 IF C=""
- Begin DoDot:3
- +43 SET C="** Null **"
- SET $PIECE(^DIST(.404,B,40,F,0),U,2)=C
- SET $PIECE(^(2),U,4)=""
- +44 if T'=1
- SET C=C_":"
- End DoDot:3
- +45 SET C2="1,1"
- SET $PIECE(^DIST(.404,B,40,F,2),U,3)=C2
- End DoDot:2
- +46 ;
- +47 ;Make sure nonCaption fields have data coordinates and length
- +48 IF T'=1
- Begin DoDot:2
- +49 if 'D2
- SET D2=+C2_","_($PIECE(C2,",",2)+$LENGTH(C)+1)
- SET $PIECE(^DIST(.404,B,40,F,2),U)=D2
- +50 if 'L
- SET L=1
- SET $PIECE(^DIST(.404,B,40,F,2),U,2)=1
- +51 IF C=""
- IF C2
- SET C2=""
- SET $PIECE(^DIST(.404,B,40,F,2),U,3)=""
- End DoDot:2
- +52 ;
- +53 IF C]""
- Begin DoDot:2
- +54 SET C1=$PIECE(C2,",")-1+B1
- SET C2=$PIECE(C2,",",2)-1+B2
- SET C3=C2+$LENGTH(C)-1
- +55 SET @DDGFREF@("F",P,B,F)=C1_U_C2_U_C3_U_C
- +56 SET @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")=""
- +57 DO WRITE^DDGLIBW(DDGFWID,C,C1-P1,C2-P2,"",$GET(V))
- End DoDot:2
- +58 ;
- +59 ;NonCaption fields
- +60 IF T'=1
- Begin DoDot:2
- +61 SET D1=$PIECE(D2,",")-1+B1
- SET D2=$PIECE(D2,",",2)-1+B2
- SET D3=D2+L-1
- +62 SET $PIECE(@DDGFREF@("F",P,B,F),U,5,8)=D1_U_D2_U_D3_U_L
- +63 SET @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")=""
- +64 DO WRITE^DDGLIBW(DDGFWID,$TRANSLATE($JUSTIFY("",L)," ","_"),D1-P1,D2-P2,"",$GET(V))
- End DoDot:2
- End DoDot:1
- +65 QUIT