Routine: DDGFHBK

DDGFHBK ;SFISC/MKO-ADD, EDIT, DELETE HEADER BLOCK ;01:48 PM  22 Nov 1994

 ;;22.0;VA FileMan;;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

ADD ;Add a header block

 ;Check to see if a header block already exists for this page

 S DDGFBH=$P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)

 I DDGFBH D MSG^DDGF($C(7)_"This page already has a header block.") H 2 D MSG^DDGF() K DDGFBH Q

N B

 S DDGFDY=DY,DDGFDX=DX

 ;Invoke form to enter block name

 K DDGFBNUM,DDGFBNAM

 D DDS(.404,"[DDGF HEADER BLOCK SELECT]")

 G:$G(DDGFBNUM)=DDGFBH!'$G(DDGFBNUM) ADDQ

 I $D(^DIST(.403,+DDGFFM,40,DDGFPG,40,"B",DDGFBNUM)) D DDS(.404,"[DDGF BLOCK ADD]","",21) G ADDQ

 S $P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)=DDGFBNUM

 ;If this looks like a brand new block, stuff in DD number

 I $L(^DIST(.404,DDGFBNUM,0),U)=1,'$O(^(0)) D

 . S DIE="^DIST(.404,",DA=DDGFBNUM

 . S DR="1////"_$P(^DIST(.403,+DDGFFM,0),U,8)

 . D ^DIE K DIE,DA,DR

 D:DDGFBH DELETE^DDGFBK(DDGFBH,1)

 D BK^DDGFLOAD(DDGFPG,DDGFBNUM,$P(DDGFLIM,U),$P(DDGFLIM,U,2),0,0,1,1)

 S DY=DDGFDY,DX=DDGFDX

 S B=DDGFBNUM,C=$P(@DDGFREF@("F",DDGFPG,B),U,4)

 S DDGFADD=1

 K DDGFBNUM,DDGFBNAM

 G EDIT

ADDQ ;Abort adding a header block

 D REFRESH^DDGF,RC(DDGFDY,DDGFDX)

 K DDGFANS,DDGFBH,DDGFBNUM,DDGFBNAM,DDGFDY,DDGFDX

EDIT ;Edit/Delete header block

 ;In: B,C

 N C1,C2,C3

 S DDGFDY=DY,DDGFDX=DX,DDGFBH=B

 S (DDGFBKNN,DDGFBKNO)=C

 S DDSFILE=.403,DDSFILE(1)=.4031,DA(1)=+DDGFFM,DA=DDGFPG

 S DR="[DDGF HEADER BLOCK EDIT]",DDSPARM="KTW"

 D ^DDS K DDSFILE,DA,DR,DDSPARM

 S DDGFBHN=$P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)

 I DDGFBHN'=DDGFBH D

 . D DELETE^DDGFBK(DDGFBH,DDGFBHN)

 . D:DDGFBHN BK^DDGFLOAD(DDGFPG,DDGFBHN,$P(DDGFLIM,U),$P(DDGFLIM,U,2),0,0,1,1)

 S C=DDGFBKNN,B=DDGFBHN

 ;Update TMP if coordinates or name changed, or new block

 I DDGFBKNN'=DDGFBKNO!$G(DDGFADD) D

 . D WRITE^DDGLIBW(DDGFWIDB,$J("",$L(DDGFBKNO)),$P(DDGFLIM,U),$P(DDGFLIM,U,2),"",1)

 . D WRITE^DDGLIBW(DDGFWIDB,C,$P(DDGFLIM,U),$P(DDGFLIM,U,2),"",1)

 D REFRESH^DDGF,RC(DDGFDY,DDGFDX)

 S:'$G(DDGFADD) DDGFE=1

 K DDGFADD,DDGFBH,DDGFBHN,DDGFBKNN,DDGFBKNO,DDGFDY,DDGFDX

DDS(DDSFILE,DR,DA,DDSPAGE) ;

 ;Call DDS

 S DDSPARM="KTW" D ^DDS K DDSPARM

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

DDGFHBK   ;SFISC/MKO-ADD, EDIT, DELETE HEADER BLOCK ;01:48 PM  22 Nov 1994

 +1       ;;22.0;VA FileMan;;Mar 30, 1999

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

ADD       ;Add a header block

 +1       ;Check to see if a header block already exists for this page

 +2        SET DDGFBH=$PIECE(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)

 +3        IF DDGFBH

               DO MSG^DDGF($CHAR(7)_"This page already has a header block.")

               HANG 2

               DO MSG^DDGF()

               KILL DDGFBH

               QUIT

 +4       ;

 +5        NEW B

 +6        SET DDGFDY=DY

           SET DDGFDX=DX

 +7       ;

 +8       ;Invoke form to enter block name

 +9        KILL DDGFBNUM,DDGFBNAM

 +10       DO DDS(.404,"[DDGF HEADER BLOCK SELECT]")

 +11       IF $GET(DDGFBNUM)=DDGFBH!'$GET(DDGFBNUM)

               GOTO ADDQ

 +12      ;

 +13       IF $DATA(^DIST(.403,+DDGFFM,40,DDGFPG,40,"B",DDGFBNUM))

               DO DDS(.404,"[DDGF BLOCK ADD]","",21)

               GOTO ADDQ

 +14      ;

 +15       SET $PIECE(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)=DDGFBNUM

 +16      ;

 +17      ;If this looks like a brand new block, stuff in DD number

 +18       IF $LENGTH(^DIST(.404,DDGFBNUM,0),U)=1

               IF '$ORDER(^(0))

                   Begin DoDot:1

 +19                   SET DIE="^DIST(.404,"

                       SET DA=DDGFBNUM

 +20                   SET DR="1////"_$PIECE(^DIST(.403,+DDGFFM,0),U,8)

 +21                   DO ^DIE

                       KILL DIE,DA,DR

                   End DoDot:1

 +22      ;

 +23       IF DDGFBH

               DO DELETE^DDGFBK(DDGFBH,1)

 +24       DO BK^DDGFLOAD(DDGFPG,DDGFBNUM,$PIECE(DDGFLIM,U),$PIECE(DDGFLIM,U,2),0,0,1,1)

 +25      ;

 +26       SET DY=DDGFDY

           SET DX=DDGFDX

 +27       SET B=DDGFBNUM

           SET C=$PIECE(@DDGFREF@("F",DDGFPG,B),U,4)

 +28       SET DDGFADD=1

 +29       KILL DDGFBNUM,DDGFBNAM

 +30       GOTO EDIT

 +31      ;

ADDQ      ;Abort adding a header block

 +1        DO REFRESH^DDGF

           DO RC(DDGFDY,DDGFDX)

 +2        KILL DDGFANS,DDGFBH,DDGFBNUM,DDGFBNAM,DDGFDY,DDGFDX

 +3        QUIT

 +4       ;

EDIT      ;Edit/Delete header block

 +1       ;In: B,C

 +2        NEW C1,C2,C3

 +3        SET DDGFDY=DY

           SET DDGFDX=DX

           SET DDGFBH=B

 +4        SET (DDGFBKNN,DDGFBKNO)=C

 +5        SET DDSFILE=.403

           SET DDSFILE(1)=.4031

           SET DA(1)=+DDGFFM

           SET DA=DDGFPG

 +6        SET DR="[DDGF HEADER BLOCK EDIT]"

           SET DDSPARM="KTW"

 +7        DO ^DDS

           KILL DDSFILE,DA,DR,DDSPARM

 +8        SET DDGFBHN=$PIECE(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)

 +9       ;

 +10       IF DDGFBHN'=DDGFBH

               Begin DoDot:1

 +11               DO DELETE^DDGFBK(DDGFBH,DDGFBHN)

 +12               IF DDGFBHN

                       DO BK^DDGFLOAD(DDGFPG,DDGFBHN,$PIECE(DDGFLIM,U),$PIECE(DDGFLIM,U,2),0,0,1,1)

               End DoDot:1

 +13      ;

 +14       SET C=DDGFBKNN

           SET B=DDGFBHN

 +15      ;

 +16      ;Update TMP if coordinates or name changed, or new block

 +17       IF DDGFBKNN'=DDGFBKNO!$GET(DDGFADD)

               Begin DoDot:1

 +18               DO WRITE^DDGLIBW(DDGFWIDB,$JUSTIFY("",$LENGTH(DDGFBKNO)),$PIECE(DDGFLIM,U),$PIECE(DDGFLIM,U,2),"",1)

 +19               DO WRITE^DDGLIBW(DDGFWIDB,C,$PIECE(DDGFLIM,U),$PIECE(DDGFLIM,U,2),"",1)

               End DoDot:1

 +20      ;

 +21       DO REFRESH^DDGF

           DO RC(DDGFDY,DDGFDX)

 +22       IF '$GET(DDGFADD)

               SET DDGFE=1

 +23       KILL DDGFADD,DDGFBH,DDGFBHN,DDGFBKNN,DDGFBKNO,DDGFDY,DDGFDX

 +24       QUIT

 +25      ;

DDS(DDSFILE,DR,DA,DDSPAGE) ;

 +1       ;Call DDS

 +2        SET DDSPARM="KTW"

           DO ^DDS

           KILL DDSPARM

 +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

DDGFHBK.m