DDGFPG ;SFISC/MKO-ADD A NEW PAGE ;2:26 PM 13 Sep 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.
;
ADD ;Invoke forms to add a new page
S DDGFDY=DY,DDGFDX=DX K DDGFPNUM
;
;Ask for new page number
S DDSFILE=.403,DDSFILE(1)=.4031
S DA(1)=+DDGFFM,DA="",DR="[DDGF PAGE ADD]",DDSPARM="KTW"
D ^DDS K DDSFILE,DA,DR,DDSPARM
;
G:$D(DDGFPNUM)[0 ADDQ
;
;Ask 'are you sure' page should be added
K DDGFANS
S DDSFILE=.403,DDSFILE(1)=.4031
S DR="[DDGF PAGE ADD]",DA(1)=+DDGFFM,DA="",DDSPARM="KTW",DDSPAGE=11
D ^DDS K DDSFILE,DA,DR,DDSPARM,DDSPAGE
;
I '$G(DDGFANS) K DDGFANS G ADDQ
K DDGFANS
;
;Add page to form
S DIC="^DIST(.403,+DDGFFM,40,",DIC(0)="L",DA(1)=+DDGFFM
S DIC("P")=$P(^DD(.403,40,0),U,2),X=DDGFPNUM
K DD,DO D FILE^DICN K DIC,DA,X G:Y=-1 ADDQ
S DDGFPG=+Y
;
;Stuff in values for coordinates and name
S DIE="^DIST(.403,"_+DDGFFM_",40,",DA(1)=+DDGFFM,DA=DDGFPG
S DR="2////1,1;7////Page "_DDGFPNUM
D ^DIE K DIE,DA,DR
;
K DDGFPNUM
D LOADPG
S DDGFNEW=1
G EDIT
;
ADDQ D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
K DDGFPNUM,DDGFDY,DDGFDX
Q
;
EDIT ;Invoke form to edit a page
;Input: DDGFNEW (optional)
; Set by ADD to indicate this is a brand new page.
;
S DDGFDY=DY,DDGFDX=DX
S DDGFND=@DDGFREF@("F",DDGFPG)
S (DDGFTLC,DDGFTLC0)=$P(DDGFND,U)+1_","_($P(DDGFND,U,2)+1)
S (DDGFLRC,DDGFLRC0)=$S($P(DDGFND,U,3)]"":$P(DDGFND,U,3)+1_","_($P(DDGFND,U,4)+1),1:"")
S (DDGFPNM,DDGFPNM0)=$P(DDGFND,U,5)
S DDGFPAR=$P($G(^DIST(.403,+DDGFFM,40,DDGFPG,1)),U,2)
;
S DDSFILE=.403,DDSFILE(1)=.4031,DDSPARM="KTW"
S DA(1)=+DDGFFM,DA=DDGFPG,DR="[DDGF PAGE EDIT]"
D ^DDS K DDSFILE,DA,DR,DDSPARM
;
S DDGFND=$G(^DIST(.403,+DDGFFM,40,DDGFPG,0))
;
;If page was deleted, destroy windows and set new page
I DDGFND="" D Q:DDGFE
. I $D(DDGFWID)#2,$$EXIST^DDGLIBW(DDGFWID) D DESTROY^DDGLIBW(DDGFWID)
. I $D(DDGFWIDB)#2,$$EXIST^DDGLIBW(DDGFWIDB) D DESTROY^DDGLIBW(DDGFWIDB)
. K @DDGFREF@("F",DDGFPG),@DDGFREF@("RC",DDGFWID),@DDGFREF@("BKRC",DDGFWIDB)
. I $D(@DDGFREF@("ASUB","B",DDGFPG)) D DEL^DDGFASUB(DDGFPG)
. S DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B",""))
. S:DDGFPG]"" DDGFPG=$O(^DIST(.403,+DDGFFM,40,"B",DDGFPG,""))
. D LOADPG,REFRESH^DDGF,RC(DDGFDY,DDGFDX)
;
E D
. S:DDGFPNM'=DDGFPNM0 $P(@DDGFREF@("F",DDGFPG),U,5)=DDGFPNM,$P(^(DDGFPG),U,7)=1,DDGFCHG=1
. D:DDGFPAR'=$P($G(^DIST(.403,+DDGFFM,40,DDGFPG,1)),U,2) EDIT^DDGFASUB(DDGFPG)
. I DDGFTLC'=DDGFTLC0!(DDGFLRC'=DDGFLRC0) D
.. D PAGE^DDGFUPDP($P(DDGFTLC,",")-1,$P(DDGFTLC,",",2)-1,$S(DDGFLRC]"":$P(DDGFLRC,",")-1,1:""),$S(DDGFLRC]"":$P(DDGFLRC,",",2)-1,1:""),$S(DDGFTLC=DDGFTLC0:"PBRC",1:"PTOP"))
.. D STATUS^DDGF,RC($P(DDGFLIM,U),$P(DDGFLIM,U,2))
. E D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
;
K DDGFDX,DDGFDY,DDGFND,DDGFNEW
K DDGFLRC,DDGFLRC0,DDGFPOP,DDGFPOP0,DDGFTLC,DDGFTLC0
K DDGFPAR,DDGFPNM,DDGFPNM0
Q
;
PGSEL ;Select a new page
S DDGFDY=DY,DDGFDX=DX,DDGFPAGE=DDGFPG
;
S DDSFILE=.403,DDSFILE(1)=.4031
S DR="[DDGF PAGE SELECT]",DDSPARM="KTW"
D ^DDS
K DDSFILE,DA,DR,DDSPAGE,DDSPARM
;
I DDGFPAGE]"",DDGFPAGE'=DDGFPG S DDGFPG=DDGFPAGE D LOADPG
;
D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
K DDGFPAGE,DDGFDY,DDGFDX
Q
;
NXTPRV(F) ;Go to page
;F=1:next page; -1:previous page
S DDGFPAGE=$P($G(^DIST(.403,+DDGFFM,40,DDGFPG,0)),U,$S($G(F)=-1:5,1:4))
G:DDGFPAGE="" NXTPRVQ
S DDGFPAGE=$O(^DIST(.403,+DDGFFM,40,"B",DDGFPAGE,""))
G:$D(^DIST(.403,+DDGFFM,40,+DDGFPAGE,0))[0!(DDGFPAGE=DDGFPG) NXTPRVQ
;
S DDGFPG=DDGFPAGE
D LOADPG,REFRESH^DDGF,RC(DDGFDY,DDGFDX)
NXTPRVQ K DDGFPAGE,DDGFDY,DDGFDX
Q
;
CLSPG ;Close page
Q:$G(DDGLSCR)'>1
D CLOSE^DDGLIBW(DDGFWID)
S DDGFPG=$E(DDGLSCR(DDGLSCR),2,999)
D PG^DDGFLOAD(+DDGFFM,DDGFPG,1)
D STATUS^DDGF,RC($P(DDGFLIM,U),$P(DDGFLIM,U,2))
Q
;
SUBPG ;Go into subpage
I $D(@DDGFREF@("ASUB",DDGFPG,B,F))#2 S DDGFSUBP=^(F)
E D
. S DDGFSUBP=+$P($G(^DIST(.404,B,40,F,7)),U,2)
. S DDGFSUBP=+$O(^DIST(.403,+DDGFFM,40,"B",DDGFSUBP,""))
;
I $D(^DIST(.403,+DDGFFM,40,DDGFSUBP,0))[0 W $C(7) K DDGFSUBP Q
I DDGFSUBP=DDGFPG K DDGFSUBP Q
S DDGFE=1
Q
;
SUBPG1 S DDGFPG=DDGFSUBP K DDGFSUBP
D PG^DDGFLOAD(+DDGFFM,DDGFPG)
D STATUS^DDGF,RC($P(DDGFLIM,U),$P(DDGFLIM,U,2))
Q
;
LOADPG ;Load new page
D PG^DDGFLOAD(+DDGFFM,DDGFPG,1)
S DDGFDY=$P(DDGFLIM,U),DDGFDX=$P(DDGFLIM,U,2)
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[HDDGFPG 4801 printed Dec 13, 2024@02:42:28 Page 2
DDGFPG ;SFISC/MKO-ADD A NEW PAGE ;2:26 PM 13 Sep 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 ;
ADD ;Invoke forms to add a new page
+1 SET DDGFDY=DY
SET DDGFDX=DX
KILL DDGFPNUM
+2 ;
+3 ;Ask for new page number
+4 SET DDSFILE=.403
SET DDSFILE(1)=.4031
+5 SET DA(1)=+DDGFFM
SET DA=""
SET DR="[DDGF PAGE ADD]"
SET DDSPARM="KTW"
+6 DO ^DDS
KILL DDSFILE,DA,DR,DDSPARM
+7 ;
+8 if $DATA(DDGFPNUM)[0
GOTO ADDQ
+9 ;
+10 ;Ask 'are you sure' page should be added
+11 KILL DDGFANS
+12 SET DDSFILE=.403
SET DDSFILE(1)=.4031
+13 SET DR="[DDGF PAGE ADD]"
SET DA(1)=+DDGFFM
SET DA=""
SET DDSPARM="KTW"
SET DDSPAGE=11
+14 DO ^DDS
KILL DDSFILE,DA,DR,DDSPARM,DDSPAGE
+15 ;
+16 IF '$GET(DDGFANS)
KILL DDGFANS
GOTO ADDQ
+17 KILL DDGFANS
+18 ;
+19 ;Add page to form
+20 SET DIC="^DIST(.403,+DDGFFM,40,"
SET DIC(0)="L"
SET DA(1)=+DDGFFM
+21 SET DIC("P")=$PIECE(^DD(.403,40,0),U,2)
SET X=DDGFPNUM
+22 KILL DD,DO
DO FILE^DICN
KILL DIC,DA,X
if Y=-1
GOTO ADDQ
+23 SET DDGFPG=+Y
+24 ;
+25 ;Stuff in values for coordinates and name
+26 SET DIE="^DIST(.403,"_+DDGFFM_",40,"
SET DA(1)=+DDGFFM
SET DA=DDGFPG
+27 SET DR="2////1,1;7////Page "_DDGFPNUM
+28 DO ^DIE
KILL DIE,DA,DR
+29 ;
+30 KILL DDGFPNUM
+31 DO LOADPG
+32 SET DDGFNEW=1
+33 GOTO EDIT
+34 ;
ADDQ DO REFRESH^DDGF
DO RC(DDGFDY,DDGFDX)
+1 KILL DDGFPNUM,DDGFDY,DDGFDX
+2 QUIT
+3 ;
EDIT ;Invoke form to edit a page
+1 ;Input: DDGFNEW (optional)
+2 ; Set by ADD to indicate this is a brand new page.
+3 ;
+4 SET DDGFDY=DY
SET DDGFDX=DX
+5 SET DDGFND=@DDGFREF@("F",DDGFPG)
+6 SET (DDGFTLC,DDGFTLC0)=$PIECE(DDGFND,U)+1_","_($PIECE(DDGFND,U,2)+1)
+7 SET (DDGFLRC,DDGFLRC0)=$SELECT($PIECE(DDGFND,U,3)]"":$PIECE(DDGFND,U,3)+1_","_($PIECE(DDGFND,U,4)+1),1:"")
+8 SET (DDGFPNM,DDGFPNM0)=$PIECE(DDGFND,U,5)
+9 SET DDGFPAR=$PIECE($GET(^DIST(.403,+DDGFFM,40,DDGFPG,1)),U,2)
+10 ;
+11 SET DDSFILE=.403
SET DDSFILE(1)=.4031
SET DDSPARM="KTW"
+12 SET DA(1)=+DDGFFM
SET DA=DDGFPG
SET DR="[DDGF PAGE EDIT]"
+13 DO ^DDS
KILL DDSFILE,DA,DR,DDSPARM
+14 ;
+15 SET DDGFND=$GET(^DIST(.403,+DDGFFM,40,DDGFPG,0))
+16 ;
+17 ;If page was deleted, destroy windows and set new page
+18 IF DDGFND=""
Begin DoDot:1
+19 IF $DATA(DDGFWID)#2
IF $$EXIST^DDGLIBW(DDGFWID)
DO DESTROY^DDGLIBW(DDGFWID)
+20 IF $DATA(DDGFWIDB)#2
IF $$EXIST^DDGLIBW(DDGFWIDB)
DO DESTROY^DDGLIBW(DDGFWIDB)
+21 KILL @DDGFREF@("F",DDGFPG),@DDGFREF@("RC",DDGFWID),@DDGFREF@("BKRC",DDGFWIDB)
+22 IF $DATA(@DDGFREF@("ASUB","B",DDGFPG))
DO DEL^DDGFASUB(DDGFPG)
+23 SET DDGFPG=$ORDER(^DIST(.403,+DDGFFM,40,"B",""))
+24 if DDGFPG]""
SET DDGFPG=$ORDER(^DIST(.403,+DDGFFM,40,"B",DDGFPG,""))
+25 DO LOADPG
DO REFRESH^DDGF
DO RC(DDGFDY,DDGFDX)
End DoDot:1
if DDGFE
QUIT
+26 ;
+27 IF '$TEST
Begin DoDot:1
+28 if DDGFPNM'=DDGFPNM0
SET $PIECE(@DDGFREF@("F",DDGFPG),U,5)=DDGFPNM
SET $PIECE(^(DDGFPG),U,7)=1
SET DDGFCHG=1
+29 if DDGFPAR'=$PIECE($GET(^DIST(.403,+DDGFFM,40,DDGFPG,1)),U,2)
DO EDIT^DDGFASUB(DDGFPG)
+30 IF DDGFTLC'=DDGFTLC0!(DDGFLRC'=DDGFLRC0)
Begin DoDot:2
+31 DO PAGE^DDGFUPDP($PIECE(DDGFTLC,",")-1,$PIECE(DDGFTLC,",",2)-1,$SELECT(DDGFLRC]"":$PIECE(DDGFLRC,",")-1,1:""),$SELECT(DDGFLRC]"":$PIECE(DDGFLRC,",",2)-1,1:""),$SELECT(DDGFTLC=DDGFTLC0:"PBRC",1:"PTOP"))
+32 DO STATUS^DDGF
DO RC($PIECE(DDGFLIM,U),$PIECE(DDGFLIM,U,2))
End DoDot:2
+33 IF '$TEST
DO REFRESH^DDGF
DO RC(DDGFDY,DDGFDX)
End DoDot:1
+34 ;
+35 KILL DDGFDX,DDGFDY,DDGFND,DDGFNEW
+36 KILL DDGFLRC,DDGFLRC0,DDGFPOP,DDGFPOP0,DDGFTLC,DDGFTLC0
+37 KILL DDGFPAR,DDGFPNM,DDGFPNM0
+38 QUIT
+39 ;
PGSEL ;Select a new page
+1 SET DDGFDY=DY
SET DDGFDX=DX
SET DDGFPAGE=DDGFPG
+2 ;
+3 SET DDSFILE=.403
SET DDSFILE(1)=.4031
+4 SET DR="[DDGF PAGE SELECT]"
SET DDSPARM="KTW"
+5 DO ^DDS
+6 KILL DDSFILE,DA,DR,DDSPAGE,DDSPARM
+7 ;
+8 IF DDGFPAGE]""
IF DDGFPAGE'=DDGFPG
SET DDGFPG=DDGFPAGE
DO LOADPG
+9 ;
+10 DO REFRESH^DDGF
DO RC(DDGFDY,DDGFDX)
+11 KILL DDGFPAGE,DDGFDY,DDGFDX
+12 QUIT
+13 ;
NXTPRV(F) ;Go to page
+1 ;F=1:next page; -1:previous page
+2 SET DDGFPAGE=$PIECE($GET(^DIST(.403,+DDGFFM,40,DDGFPG,0)),U,$SELECT($GET(F)=-1:5,1:4))
+3 if DDGFPAGE=""
GOTO NXTPRVQ
+4 SET DDGFPAGE=$ORDER(^DIST(.403,+DDGFFM,40,"B",DDGFPAGE,""))
+5 if $DATA(^DIST(.403,+DDGFFM,40,+DDGFPAGE,0))[0!(DDGFPAGE=DDGFPG)
GOTO NXTPRVQ
+6 ;
+7 SET DDGFPG=DDGFPAGE
+8 DO LOADPG
DO REFRESH^DDGF
DO RC(DDGFDY,DDGFDX)
NXTPRVQ KILL DDGFPAGE,DDGFDY,DDGFDX
+1 QUIT
+2 ;
CLSPG ;Close page
+1 if $GET(DDGLSCR)'>1
QUIT
+2 DO CLOSE^DDGLIBW(DDGFWID)
+3 SET DDGFPG=$EXTRACT(DDGLSCR(DDGLSCR),2,999)
+4 DO PG^DDGFLOAD(+DDGFFM,DDGFPG,1)
+5 DO STATUS^DDGF
DO RC($PIECE(DDGFLIM,U),$PIECE(DDGFLIM,U,2))
+6 QUIT
+7 ;
SUBPG ;Go into subpage
+1 IF $DATA(@DDGFREF@("ASUB",DDGFPG,B,F))#2
SET DDGFSUBP=^(F)
+2 IF '$TEST
Begin DoDot:1
+3 SET DDGFSUBP=+$PIECE($GET(^DIST(.404,B,40,F,7)),U,2)
+4 SET DDGFSUBP=+$ORDER(^DIST(.403,+DDGFFM,40,"B",DDGFSUBP,""))
End DoDot:1
+5 ;
+6 IF $DATA(^DIST(.403,+DDGFFM,40,DDGFSUBP,0))[0
WRITE $CHAR(7)
KILL DDGFSUBP
QUIT
+7 IF DDGFSUBP=DDGFPG
KILL DDGFSUBP
QUIT
+8 SET DDGFE=1
+9 QUIT
+10 ;
SUBPG1 SET DDGFPG=DDGFSUBP
KILL DDGFSUBP
+1 DO PG^DDGFLOAD(+DDGFFM,DDGFPG)
+2 DO STATUS^DDGF
DO RC($PIECE(DDGFLIM,U),$PIECE(DDGFLIM,U,2))
+3 QUIT
+4 ;
LOADPG ;Load new page
+1 DO PG^DDGFLOAD(+DDGFFM,DDGFPG,1)
+2 SET DDGFDY=$PIECE(DDGFLIM,U)
SET DDGFDX=$PIECE(DDGFLIM,U,2)
+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
