Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DDGFFM

DDGFFM.m

Go to the documentation of this file.
DDGFFM ;SFISC/MKO-FORM ADD, EDIT, SELECT ;8MAR2016
 ;;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.
 ;
SEL ;Select another form
ADD ;Add a new form
 N X,DIR0 K DDGFABT
 S DDGFDY=+$G(DY),DDGFDX=+$G(DX),(DY,DX)=0 X IOXY
 W $P(DDGLCLR,DDGLDEL,2)
 X DDGLZOSF("EON"),DDGLZOSF("TRMOFF")
 ;
 ;Select file
FIL S DDS1=8107 D W^DICRW K DDS1 G:Y<0 ADDQ ;**CCO/NI  EDIT/CREATE FORM
 G:'$D(@(DIC_"0)")) ADDQ
 ;
 ;Select form
 W !
 S DIC("S")="I $P(^(0),U,8)=+DDGFFILE"
 I DUZ(0)'="@" S DIC("S")=DIC("S")_" N DDSI F DDSI=1:1:$L($P(^(0),U,3)) I DUZ(0)[$E($P(^(0),U,3),DDSI) Q"
 S DDGFFILE=Y,DIC=.403,DIC(0)="QEAL",D="F"_+Y
 D IX^DIC K DIC,D G:Y<0 ADDQ
 S DDGFY=Y
 ;
 ;Save data for previous form
 I DDGFCHG,$D(DDGFFM)#2 G:+DDGFFM=+DDGFY ADDQ D  G:$G(DDGFABT) ADDQ
 . N DDGFFNAM
 . S DIR(0)="Y",DDGFFNAM=$P(DDGFFM,U,2)
 . S DIR("A")="Save changes to form "_DDGFFNAM
 . S DIR("B")="YES"
 . S DIR("?",1)="  Enter 'Y' or press 'Return' to save changes."
 . S DIR("?",2)="  Enter 'N' to discard changes."
 . S DIR("?")="  Enter '^' to return to form "_DDGFFNAM
 . W ! D ^DIR K DIR I $D(DIRUT) K DIRUT,DUOUT,DTOUT S DDGFABT=1 Q
 . D SAVE^DDGFSV
 ;
 I $D(DDGFFM)#2,+DDGFFM'=+DDGFY D RECOMP^DDGF0
 ;
 S DDGFFM=$P(DDGFY,U,1,2)
 ;
 ;Stuff in values for form
 K DR S DIE=.403,DA=+DDGFY,DDGFNEW=$P(DDGFY,U,3)
 S:DDGFNEW DR="3////"_DUZ_";4///NOW"
 S DR=$S($G(DR)]"":DR_";",1:"")_"5///NOW"
 S:DDGFNEW DR=DR_";7////"_+DDGFFILE
 D ^DIE K DIE,DA,DR,D,%DT
 I DDGFNEW,$G(DUZ(0))]"" D
 . S $P(^DIST(.403,+DDGFFM,0),U,2,3)=DUZ(0)_U_DUZ(0)
 ;
 ;If this is a new form, create Page 1
 N GFT I DDGFNEW D  Q:$D(GFT)
 . K DD,DO
 . S DIC="^DIST(.403,+DDGFFM,40,",DIC("P")=$P(^DD(.403,40,0),U,2)
 . S DIC(0)="",DA(1)=+DDGFFM,X=1
 . D FILE^DICN I Y=-1 K DIC,Y Q
 . S DIE=DIC,DA=+Y,DR="2////1,1;7////Page 1"
 . D ^DIE K DIC,DIE,DA,DR,D,Y
SELPAGE .S Y=^DIC(+DDGFFILE,0,"GL") I $P($G(@(Y_"0)")),U,4)<999  D  I Y=1 D GFT K DDGFFM W !!,"DONE!",! Q
 ..N DIR S DIR(0)="Y",DIR("A")="Do you want your Form to begin with a display of all entries, for selection"
 ..S DIR("?")="Answer YES to save setup time!",DIR("?",1)="Your Form can automatically present a scrolling list of all entries"
 ..I $O(^DD(+DDGFFILE,0,"ID",0)) S DIR("?",2)="including IDENTIFIER fields"
 ..D ^DIR
 ;
 ;Clear data for previous form
 W $P(DDGLCLR,DDGLDEL,2)
 I $D(@DDGFREF) K @DDGFREF D DESTALL^DDGLIBW
 ;
 ;Get first page, load form
 S DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B",""))
 I DDGFPG]"" S DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B",DDGFPG,""))
 D PG^DDGFLOAD(+DDGFFM,DDGFPG),STATUS^DDGF
 S DDGFDY=$P(DDGFLIM,U),DDGFDX=$P(DDGFLIM,U,2)
 ;
ADDQQ X DDGLZOSF("EOFF"),DDGLZOSF("TRMON")
 D RC(DDGFDY,DDGFDX)
 K DDGFABT,DDGFDY,DDGFDX,DDGFNEW,DDGFY
 Q
 ;
 ;
GFT ;BUILD A SELECTION PAGE -- called from SELPAGE above
 N DO,DIC,FLD,LN,L,DLAYGO,GFTQUIT,GFTID,GFTPOS,DDGH
 S (DLAYGO,DIC)=.404,X=$P(DDGFY,U,2),DIC(0)="LX",DIC("DR")="1////"_+DDGFFILE D FILE^DICN ;CREATE NEW BLOCK FOR DATA
 S DDGFBLK=+Y Q:'$P(Y,U,3)
 S (DLAYGO,DIC)=.404,X=$P(DDGFY,U,2)_" HEADER",DIC(0)="LX",DIC("DR")="1////"_+DDGFFILE D FILE^DICN ;CREATE NEW HEADER BLOCK
 S DDGH=+Y
 S FLD=0,GFTID=U,GFTPOS=2
 S GFT=.01 F  S FLD=FLD+1 D  Q:$G(GFTQUIT)  S GFT=$O(^DD(+DDGFFILE,0,"ID",GFT)) Q:'GFT
 .D FIELD^DID(+DDGFFILE,GFT,"","FIELD LENGTH;LABEL","GFT(GFT)")
 .S L=GFT(GFT,"LABEL") I $L(GFTID)+$L(L)+$L(GFTID,U)>74 S GFTQUIT=1,FLD=FLD-1 Q  ;HEADER RESTRICTS NUMBER OF FIELDS
 .S LN=GFT(GFT,"FIELD LENGTH") S:LN>74 LN=74 S GFTID(FLD)=LN,GFTPOS(FLD)=GFTPOS,GFTPOS=GFTPOS+LN+2,GFTID(FLD,1)=GFT,GFTID=GFTID_L_U
 F  S L=GFTPOS-79\FLD Q:L<1  S LN=0 F X=1:1:FLD D
 .I GFTID(X)-1<6 Q
 .S GFTID(X)=GFTID(X)-1,GFTPOS=GFTPOS-1,GFTPOS(X)=GFTPOS(X)-LN,LN=LN+1 ;TRIM FIELD LENGTHS BY 1
 F X=1:1 Q:'$D(GFTID(X))  D
 .S DIC="^DIST(.404,"_DDGFBLK_",40,",DLAYGO=.4044,DA(1)=DDGFBLK,DIC(0)="LX"
 .S DIC("DR")="2////3;3.1////"_$P(GFTID,U,X+1)_";4////"_GFTID(X,1)_";4.1///2,"_GFTPOS(X)_";4.2///"_GFTID(X)
 .D FILE^DICN ;CREATE A DATA FIELD
 S DIC="^DIST(.404,"_DDGH_",40,",DA(1)=DDGH,DIC(0)="LX",X=1,DIC("DR")="2///4;4.1///1,1;4.2///80;30///S Y=$$HEADER^DDGFFM("_+DDGFFM_")"
 D FILE^DICN ;CREATE THE HEADER FIELD
 S GFT=^DIC(+DDGFFILE,0,"GL") I '$D(^DD(+DDGFFILE,0,"IX","B",+DDGFFILE,.01)) S GFT="F D=0:0 S D=$O("_GFT
 E  S GFT="S GFT="""" F  S GFT=$O("_GFT_"""B"",GFT)) Q:GFT=""""  F D=0:0 S D=$O("_GFT_"""B"",GFT," ;SHOW ENTRIES ALPHABETICALLY IF THERE IS A "B" X-REF
 S GFT=GFT_"D)) Q:'D  N Y S (Y,D0)=D "_$G(^DD(+DDGFFILE,0,"SCR"))_" X DICMX Q:'$D(D)"
 S DIE=.403,DA=+DDGFFM,DR="21///1" D ^DIE ;FORM'S RECORD SELECTION PAGE=1
 S DIC="^DIST(.403,"_DA_",40,1,40,",DA(2)=DA,DA(1)=1,(X,DINUM)=DDGFBLK,DIC(0)="UXL",DIC("P")=".4032IP",DLAYGO=.4032
 S DIC("DR")="1///1;2///2,1;3///e;5///15;98.1///"_+DDGFFILE_";98////^S X=GFT"
 D FILE^DICN ;ADD DATA BLOCK TO PAGE
 S DIE="^DIST(.403,"_+DDGFFM_",40,",DR="1////"_DDGH,DA=1 D ^DIE ;ADD HEADER BLOCK POINTER
 Q
 ;
 ;
 N B,X,F,S,L,D,FILE,Y,FILENAME,LABEL,LINE
 S X="",S=0,B=$O(^DIST(.403,FORM,"AY",1,0)) I 'B Q X
 S FILE=$P(^(B),U,3) Q:'FILE
 F F=0:0 S F=$O(^DIST(.403,FORM,"AY",1,B,F)) Q:'F  S Y=$G(^(F,"D")) Q:'Y  S:'$D(LINE) LINE=+Y Q:Y>LINE  D
 .S L=$P(Y,U,3) Q:'L
 .S D=$P(Y,U,4),LABEL=$$LABEL^DIALOGZ(FILE,D)
 .D:$L(LABEL)>L  S LABEL=$E(LABEL,1,L)
 ..N Z,T F Z=0:0 S Z=$O(^DIST(.404,B,40,Z)) Q:'Z  I $G(^(Z,1))=D S T=$P(^(0),U,5) I T]"",$L(T)<$L(LABEL) S LABEL=T Q  ;TRY SHORTER 'UNIQUE NAME'
 .I D=.01,$L(LABEL)+3<L S FILENAME=$$FILENAME^DIALOGZ(FILE) I $L(FILENAME)+$L(LABEL)<L S LABEL=FILENAME_" "_LABEL
 .S D=$P(Y,U,2),$E(X,D,D+L-1)=LABEL
 Q X
 ;
 ;
ADDQ I $D(DDGFFM)#2 D REFRESH^DDGF G ADDQQ
 K DDGFABT,DDGFDY,DDGFDX
 Q
 ;
EDIT ;Invoke form to edit form
 S DDGFDY=DY,DDGFDX=DX
 K DDSFILE S DDSFILE=.403
 S DA=+DDGFFM,DR="[DDGF FORM EDIT]",DDSPARM="KTW"
 D ^DDS K DDSFILE,DR,DDSPARM
 ;
 S $P(DDGFFM,U,2)=$P(^DIST(.403,+DDGFFM,0),U)
 D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
EDITQ K DDGFDY,DDGFDX
 Q
 ;
RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
 N DDGFS
 I DDGFR D
 . S DY=IOSL-6,DX=IOM-9,DDGFS="R"_(DDGFY+1)_",C"_(DDGFX+1)
 . X IOXY W DDGFS_$J("",7-$L(DDGFS))
 S DY=DDGFY,DX=DDGFX X IOXY
 Q