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 Dec 13, 2024@02:42:26 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
