DDGFFLDA ;SFISC/MKO - ADD A FIELD ;19APR2016
;;22.2;VA FileMan;**3,5**;Jan 05, 2016;Build 28
;;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.
;GFT;**1055**
;
ADD ;Add a field
I '$O(^DIST(.403,+DDGFFM,40,DDGFPG,40,0)) D Q
. D MSG^DDGF($C(7)_"There are no blocks defined on this page. To add a block, press <PF2>B.")
. H 2 D MSG^DDGF()
S DDGFDY=DY,DDGFDX=DX
;
;Invoke form to select block, field order, field type
K DDGFBLCK,DDGFFORD,DDGFTYPE
S DDSFILE=.404,DDSFILE(1)=.4044
S DR="[DDGF FIELD ADD]",DDSPARM="KTW"
D ^DDS K DDSFILE,DA,DR,DDSPARM
;
I '$D(DDGFBLCK)!'$D(DDGFFORD)!'$D(DDGFTYPE) G ADDQ
;
;Get relative field coordinates
S (DDGFCAP,DDGFCAP0)=""
S (DDGFSUP,DDGFSUP0)=""
S (DDGFCC,DDGFCC0)=""
;
;E.G. DDGFREF="^TMP("DDGF",$J,"F",1,791,1)="1^0^5^TIMSON"
S DDGFB2=@DDGFREF@("F",DDGFPG,DDGFBLCK)
S DDGFB1=$P(DDGFB2,U),DDGFB2=$P(DDGFB2,U,2)
;
I DDGFTYPE=1 D
. S DDGFCC0=DDGFDY-DDGFB1+1_","_(DDGFDX-DDGFB2+1)
E D
. S DDGFD1=DDGFDY-DDGFB1+1,DDGFD2=DDGFDX-DDGFB2+1
. S (DDGFDC,DDGFDC0)=DDGFD1_","_DDGFD2
. S (DDGFDL,DDGFDL0)=1
;
I DDGFTYPE'=1,DDGFD1<1!(DDGFD2<1) D G ADDQ
. D MSG^DDGF($C(7)_"Unable to add a field above or to the left of the block.")
. H 2 D MSG^DDGF()
;
K DDGFD1,DDGFD2
;
;Add field order to block file
S DIC="^DIST(.404,"_DDGFBLCK_",40,",DIC(0)="L"
S DIC("P")=$P(^DD(.404,40,0),U,2)
S DA(1)=DDGFBLCK,X=DDGFFORD
K DD,DO D FILE^DICN
I Y=-1 K DIC,DA,Y D MSG^DDGF($C(7)_"Unable to add field.") H 2 D MSG^DDGF() G ADDQ
;
;Stuff values for field type, data coordinate, and data length
;If form-only field, also stuff in default read type
S DIE=DIC,DA(1)=DDGFBLCK,DA=+Y
S DR="2////"_DDGFTYPE
S:DDGFTYPE'=1 DR=DR_";4.1////"_DDGFDC_";4.2////1"
S:DDGFTYPE=2 DR=DR_";20.1////F"
D ^DIE K DIC,DIE,DR,Y
;
;Invoke appropriate form
S DDSFILE=.404,DDSFILE(1)=.4044,DDSPARM="CKTW"
S DDGFDD=$P(^DIST(.404,DDGFBLCK,0),U,2)
S DR="[DDGF FIELD "_$P("CAPTION ONLY^FORM ONLY^DD^COMPUTED",U,DDGFTYPE)_"]" ;4 TYPES OF SCREENMAN FIELDS
D ^DDS K DDSFILE,DR,DDSPARM,DDGFDD
;
I $D(DA)#2,DDGFTYPE'=1,$G(DDSCHANG)'=1 D
. S DIK="^DIST(.404,"_DA(1)_",40,"
. D ^DIK K DIK
E I $D(DA)#2 D
. D SAVE
. D LOADF
;
ADDQ ;Refresh and cleanup
D REFRESH^DDGF
D RC(DDGFDY,DDGFDX)
;
K DA,DDSCHANG
K DDGFB1,DDGFB2,DDGFD1,DDGFD2
K DDGFSUP,DDGFSUP0,DDGFCAP,DDGFCAP0,DDGFCC,DDGFCC0
K DDGFDL,DDGFDL0,DDGFDC,DDGFDC0
K DDGFDY,DDGFDX,DDGFBLCK,DDGFFORD,DDGFTYPE
Q
;
SAVE ;Save changes to caption, coordinates, data length, and suppress
;colon flag
S:DDGFCAP="" (DDGFSUP,DDGFCC)=""
S DR=""
;
S:DDGFCAP]"" DR=DR_"1////"_DDGFCAP_";"
S:DDGFCC]"" DR=DR_"5.1////"_DDGFCC_";"
S:DDGFSUP DR=DR_"5.2////1;"
;
I DDGFTYPE'=1 D
. S:DDGFDC'=DDGFDC0 DR=DR_"4.1////"_DDGFDC_";"
. S:DDGFDL'=DDGFDL0 DR=DR_"4.2////"_DDGFDL_";"
I DR="" K DR Q
;
S DIE="^DIST(.404,"_DA(1)_",40,"
S DR=$E(DR,1,$L(DR)-1)
D ^DIE K DIE,DR,Y
Q
;
LOADF ;Set DDGFREF array and window buffer
N C,C1,C2,C3,D,D1,D2,D3,L
;
I DDGFCAP="" D
. S (C,C1,C2,C3)=""
. K @DDGFREF@("F",DDGFPG,DDGFBLCK,DA)
E D
. S C=DDGFCAP_$S(DDGFTYPE'=1&'DDGFSUP:":",1:"")
. S C1=$P(DDGFCC,",")-1+DDGFB1
. S C2=$P(DDGFCC,",",2)-1+DDGFB2
. S C3=C2+$L(C)-1
. ;
. S @DDGFREF@("F",DDGFPG,DDGFBLCK,DA)=C1_U_C2_U_C3_U_C
. S @DDGFREF@("RC",DDGFWID,C1,C2,C3,DDGFBLCK,DA,"C")=""
. D WRITE^DDGLIBW(DDGFWID,C,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"",1)
;
I DDGFTYPE'=1 D ;IF IT IS NOT CAPTION-ONLY
. S D1=$P(DDGFDC,",")-1+DDGFB1
. S D2=$P(DDGFDC,",",2)-1+DDGFB2
. S D3=D2+DDGFDL-1
. ;
. S $P(@DDGFREF@("F",DDGFPG,DDGFBLCK,DA),U,5,8)=D1_U_D2_U_D3_U_DDGFDL
. I D1]"",D2]"" S @DDGFREF@("RC",DDGFWID,D1,D2,D3,DDGFBLCK,DA,"D")=""
.D KILLPGS(DDGFBLCK,DDGFWID)
. D:DDGFDL WRITE^DDGLIBW(DDGFWID,$TR($J("",DDGFDL)," ","_"),D1-$P(DDGFLIM,U),D2-$P(DDGFLIM,U,2),"",1)
Q
;
KILLPGS(BLOCK,PPAGE) ;GET RID OF OTHER PAGES THAT HAVE THIS BLOCK ON THEM. PPAGE="P"_(INTERNAL PAGE) ALSO COME HERE FROM DDGFFLD
N P F P=0:0 S P=$O(@DDGFREF@("F",P)) Q:'P I $D(^(P,BLOCK)) S P("P"_P)=""
S P="" F S P=$O(P(P)) Q:P="" I P'=PPAGE K @DDGFREF@("RC",P),@DDGLREF@(P) ;!! E.G., ^TMP("DDGF",$J,"RC","P4") &^TMP("DDGL",$J,"W","P4"). PAGES WILL BE RE-CREATED WHEN NEEDED
Q
;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
N S
I DDGFR D
. S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1)
. X IOXY W S_$J("",7-$L(S))
S DY=DDGFY,DX=DDGFX X IOXY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDGFFLDA 4699 printed Apr 09, 2024@21:46:38 Page 2
DDGFFLDA ;SFISC/MKO - ADD A FIELD ;19APR2016
+1 ;;22.2;VA FileMan;**3,5**;Jan 05, 2016;Build 28
+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 ;GFT;**1055**
+7 ;
ADD ;Add a field
+1 IF '$ORDER(^DIST(.403,+DDGFFM,40,DDGFPG,40,0))
Begin DoDot:1
+2 DO MSG^DDGF($CHAR(7)_"There are no blocks defined on this page. To add a block, press <PF2>B.")
+3 HANG 2
DO MSG^DDGF()
End DoDot:1
QUIT
+4 SET DDGFDY=DY
SET DDGFDX=DX
+5 ;
+6 ;Invoke form to select block, field order, field type
+7 KILL DDGFBLCK,DDGFFORD,DDGFTYPE
+8 SET DDSFILE=.404
SET DDSFILE(1)=.4044
+9 SET DR="[DDGF FIELD ADD]"
SET DDSPARM="KTW"
+10 DO ^DDS
KILL DDSFILE,DA,DR,DDSPARM
+11 ;
+12 IF '$DATA(DDGFBLCK)!'$DATA(DDGFFORD)!'$DATA(DDGFTYPE)
GOTO ADDQ
+13 ;
+14 ;Get relative field coordinates
+15 SET (DDGFCAP,DDGFCAP0)=""
+16 SET (DDGFSUP,DDGFSUP0)=""
+17 SET (DDGFCC,DDGFCC0)=""
+18 ;
+19 ;E.G. DDGFREF="^TMP("DDGF",$J,"F",1,791,1)="1^0^5^TIMSON"
+20 SET DDGFB2=@DDGFREF@("F",DDGFPG,DDGFBLCK)
+21 SET DDGFB1=$PIECE(DDGFB2,U)
SET DDGFB2=$PIECE(DDGFB2,U,2)
+22 ;
+23 IF DDGFTYPE=1
Begin DoDot:1
+24 SET DDGFCC0=DDGFDY-DDGFB1+1_","_(DDGFDX-DDGFB2+1)
End DoDot:1
+25 IF '$TEST
Begin DoDot:1
+26 SET DDGFD1=DDGFDY-DDGFB1+1
SET DDGFD2=DDGFDX-DDGFB2+1
+27 SET (DDGFDC,DDGFDC0)=DDGFD1_","_DDGFD2
+28 SET (DDGFDL,DDGFDL0)=1
End DoDot:1
+29 ;
+30 IF DDGFTYPE'=1
IF DDGFD1<1!(DDGFD2<1)
Begin DoDot:1
+31 DO MSG^DDGF($CHAR(7)_"Unable to add a field above or to the left of the block.")
+32 HANG 2
DO MSG^DDGF()
End DoDot:1
GOTO ADDQ
+33 ;
+34 KILL DDGFD1,DDGFD2
+35 ;
+36 ;Add field order to block file
+37 SET DIC="^DIST(.404,"_DDGFBLCK_",40,"
SET DIC(0)="L"
+38 SET DIC("P")=$PIECE(^DD(.404,40,0),U,2)
+39 SET DA(1)=DDGFBLCK
SET X=DDGFFORD
+40 KILL DD,DO
DO FILE^DICN
+41 IF Y=-1
KILL DIC,DA,Y
DO MSG^DDGF($CHAR(7)_"Unable to add field.")
HANG 2
DO MSG^DDGF()
GOTO ADDQ
+42 ;
+43 ;Stuff values for field type, data coordinate, and data length
+44 ;If form-only field, also stuff in default read type
+45 SET DIE=DIC
SET DA(1)=DDGFBLCK
SET DA=+Y
+46 SET DR="2////"_DDGFTYPE
+47 if DDGFTYPE'=1
SET DR=DR_";4.1////"_DDGFDC_";4.2////1"
+48 if DDGFTYPE=2
SET DR=DR_";20.1////F"
+49 DO ^DIE
KILL DIC,DIE,DR,Y
+50 ;
+51 ;Invoke appropriate form
+52 SET DDSFILE=.404
SET DDSFILE(1)=.4044
SET DDSPARM="CKTW"
+53 SET DDGFDD=$PIECE(^DIST(.404,DDGFBLCK,0),U,2)
+54 ;4 TYPES OF SCREENMAN FIELDS
SET DR="[DDGF FIELD "_$PIECE("CAPTION ONLY^FORM ONLY^DD^COMPUTED",U,DDGFTYPE)_"]"
+55 DO ^DDS
KILL DDSFILE,DR,DDSPARM,DDGFDD
+56 ;
+57 IF $DATA(DA)#2
IF DDGFTYPE'=1
IF $GET(DDSCHANG)'=1
Begin DoDot:1
+58 SET DIK="^DIST(.404,"_DA(1)_",40,"
+59 DO ^DIK
KILL DIK
End DoDot:1
+60 IF '$TEST
IF $DATA(DA)#2
Begin DoDot:1
+61 DO SAVE
+62 DO LOADF
End DoDot:1
+63 ;
ADDQ ;Refresh and cleanup
+1 DO REFRESH^DDGF
+2 DO RC(DDGFDY,DDGFDX)
+3 ;
+4 KILL DA,DDSCHANG
+5 KILL DDGFB1,DDGFB2,DDGFD1,DDGFD2
+6 KILL DDGFSUP,DDGFSUP0,DDGFCAP,DDGFCAP0,DDGFCC,DDGFCC0
+7 KILL DDGFDL,DDGFDL0,DDGFDC,DDGFDC0
+8 KILL DDGFDY,DDGFDX,DDGFBLCK,DDGFFORD,DDGFTYPE
+9 QUIT
+10 ;
SAVE ;Save changes to caption, coordinates, data length, and suppress
+1 ;colon flag
+2 if DDGFCAP=""
SET (DDGFSUP,DDGFCC)=""
+3 SET DR=""
+4 ;
+5 if DDGFCAP]""
SET DR=DR_"1////"_DDGFCAP_";"
+6 if DDGFCC]""
SET DR=DR_"5.1////"_DDGFCC_";"
+7 if DDGFSUP
SET DR=DR_"5.2////1;"
+8 ;
+9 IF DDGFTYPE'=1
Begin DoDot:1
+10 if DDGFDC'=DDGFDC0
SET DR=DR_"4.1////"_DDGFDC_";"
+11 if DDGFDL'=DDGFDL0
SET DR=DR_"4.2////"_DDGFDL_";"
End DoDot:1
+12 IF DR=""
KILL DR
QUIT
+13 ;
+14 SET DIE="^DIST(.404,"_DA(1)_",40,"
+15 SET DR=$EXTRACT(DR,1,$LENGTH(DR)-1)
+16 DO ^DIE
KILL DIE,DR,Y
+17 QUIT
+18 ;
LOADF ;Set DDGFREF array and window buffer
+1 NEW C,C1,C2,C3,D,D1,D2,D3,L
+2 ;
+3 IF DDGFCAP=""
Begin DoDot:1
+4 SET (C,C1,C2,C3)=""
+5 KILL @DDGFREF@("F",DDGFPG,DDGFBLCK,DA)
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET C=DDGFCAP_$SELECT(DDGFTYPE'=1&'DDGFSUP:":",1:"")
+8 SET C1=$PIECE(DDGFCC,",")-1+DDGFB1
+9 SET C2=$PIECE(DDGFCC,",",2)-1+DDGFB2
+10 SET C3=C2+$LENGTH(C)-1
+11 ;
+12 SET @DDGFREF@("F",DDGFPG,DDGFBLCK,DA)=C1_U_C2_U_C3_U_C
+13 SET @DDGFREF@("RC",DDGFWID,C1,C2,C3,DDGFBLCK,DA,"C")=""
+14 DO WRITE^DDGLIBW(DDGFWID,C,C1-$PIECE(DDGFLIM,U),C2-$PIECE(DDGFLIM,U,2),"",1)
End DoDot:1
+15 ;
+16 ;IF IT IS NOT CAPTION-ONLY
IF DDGFTYPE'=1
Begin DoDot:1
+17 SET D1=$PIECE(DDGFDC,",")-1+DDGFB1
+18 SET D2=$PIECE(DDGFDC,",",2)-1+DDGFB2
+19 SET D3=D2+DDGFDL-1
+20 ;
+21 SET $PIECE(@DDGFREF@("F",DDGFPG,DDGFBLCK,DA),U,5,8)=D1_U_D2_U_D3_U_DDGFDL
+22 IF D1]""
IF D2]""
SET @DDGFREF@("RC",DDGFWID,D1,D2,D3,DDGFBLCK,DA,"D")=""
+23 DO KILLPGS(DDGFBLCK,DDGFWID)
+24 if DDGFDL
DO WRITE^DDGLIBW(DDGFWID,$TRANSLATE($JUSTIFY("",DDGFDL)," ","_"),D1-$PIECE(DDGFLIM,U),D2-$PIECE(DDGFLIM,U,2),"",1)
End DoDot:1
+25 QUIT
+26 ;
KILLPGS(BLOCK,PPAGE) ;GET RID OF OTHER PAGES THAT HAVE THIS BLOCK ON THEM. PPAGE="P"_(INTERNAL PAGE) ALSO COME HERE FROM DDGFFLD
+1 NEW P
FOR P=0:0
SET P=$ORDER(@DDGFREF@("F",P))
if 'P
QUIT
IF $DATA(^(P,BLOCK))
SET P("P"_P)=""
+2 ;!! E.G., ^TMP("DDGF",$J,"RC","P4") &^TMP("DDGL",$J,"W","P4"). PAGES WILL BE RE-CREATED WHEN NEEDED
SET P=""
FOR
SET P=$ORDER(P(P))
if P=""
QUIT
IF P'=PPAGE
KILL @DDGFREF@("RC",P),@DDGLREF@(P)
+3 QUIT
+4 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
+1 NEW S
+2 IF DDGFR
Begin DoDot:1
+3 SET DY=IOSL-6
SET DX=IOM-9
SET S="R"_(DDGFY+1)_",C"_(DDGFX+1)
+4 XECUTE IOXY
WRITE S_$JUSTIFY("",7-$LENGTH(S))
End DoDot:1
+5 SET DY=DDGFY
SET DX=DDGFX
XECUTE IOXY
+6 QUIT
