- DDGFBK ;SFISC/MKO-ADD, EDIT, DELETE BLOCK ;2:11 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 ;Add a new block
- N B,C1,C2,C3
- S DDGFDY=DY,DDGFDX=DX
- ;
- ;Invoke form to enter block name
- K DDGFBNUM,DDGFBNAM
- D DDS(.404,"[DDGF BLOCK ADD]")
- G:'$D(DDGFBNUM) ADDQ
- ;
- ;Ask whether block should be added or indicate duplicate block
- K DDGFANS
- S DDSPAGE=$S($P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)=DDGFBNUM!$D(^(40,"B",DDGFBNUM)):21,1:11)
- D DDS(.404,"[DDGF BLOCK ADD]","",DDSPAGE)
- G:DDSPAGE=21 ADDQ
- I '$G(DDGFANS) D G ADDQ
- . I $D(^DIST(.404,DDGFBNUM,0))#2,'$P(^(0),U,2) D
- .. N DIK,DA
- .. S DIK="^DIST(.404,",DA=DDGFBNUM
- .. D ^DIK
- K DDSPAGE,DDGFANS
- ;
- ;Add block to page
- S DIC="^DIST(.403,+DDGFFM,40,DDGFPG,40,",DIC(0)="L"
- S DA(2)=+DDGFFM,DA(1)=DDGFPG
- S DIC("P")=$P(^DD(.4031,40,0),U,2)
- S (DINUM,X)=DDGFBNUM
- K DO,DD D FILE^DICN K DINUM,X
- G:Y=-1 ADDQ
- ;
- ;Stuff in values for block order, coordinates, and type
- S DIE=DIC,DA=+Y
- S DDGFC=DDGFDY-$P(DDGFLIM,U)+1_","_(DDGFDX-$P(DDGFLIM,U,2)+1)
- S DR="1////"_($O(^DIST(.403,+DDGFFM,40,DDGFPG,40,"AC",""),-1)+1\1)_";2////"_DDGFC_";3////e"
- D ^DIE K DA,DIC,DIE,DR,X,Y,DDGFC
- ;
- ;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 DA,DIE,DR
- ;
- D BK^DDGFLOAD(DDGFPG,DDGFBNUM,$P(DDGFLIM,U),$P(DDGFLIM,U,2),DDGFDY,DDGFDX,0,1)
- ;
- S DY=DDGFDY,DX=DDGFDX
- S B=DDGFBNUM,C=$P(@DDGFREF@("F",DDGFPG,B),U,4)
- S C1=DY,C2=DX,C3=C2+$L(DDGFBNAM)-1
- S DDGFADD=1
- K DDGFBNUM,DDGFBNAM
- S:$G(DDGFBV) DDGFORIG(B)=DY_U_DX
- G EDIT
- ;
- ADDQ ;Adding aborted
- D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
- K DDGFANS,DDGFBNAM,DDGFBNUM,DDGFDX,DDGFDY,DDSPAGE,DA,DIC,Y
- Q
- ;
- EDIT ;Edit block
- ;In: B,C1,C2,C3,C
- S DDGFDY=DY,DDGFDX=DX
- S DDGFBK=B,DDGFC1=C1,DDGFC2=C2,DDGFC3=C3
- S DDGFBKCO=C1-$P(DDGFLIM,U)+1_","_(C2-$P(DDGFLIM,U,2)+1)
- S DDGFBKNO=C
- ;
- ;Invoke form to edit block
- S DDSFILE=.403,DDSFILE(1)=.4032
- S DA(2)=+DDGFFM,DA(1)=DDGFPG,DA=B
- S DR="[DDGF BLOCK EDIT]",DDSPARM="KTW"
- D ^DDS K DDSFILE,DA,DR,DDSPARM
- ;
- ;If block was deleted, remove data from DDGFREF
- I $D(^DIST(.403,+DDGFFM,40,DDGFPG,40,DDGFBK,0))[0 D DELETE(DDGFBK) G EDITQ
- ;
- S:$D(DDGFBKCN)[0 DDGFBKCN=DDGFBKCO
- S:$D(DDGFBKNN)[0 DDGFBKNN=DDGFBKNO
- ;
- S C=DDGFBKNN
- S C1=$P(DDGFBKCN,",")-1+$P(DDGFLIM,U)
- S C2=$P(DDGFBKCN,",",2)-1+$P(DDGFLIM,U,2)
- S C3=C2+$L(C)-1
- ;
- ;Update TMP if coordinates or name changed, or new block
- I DDGFBKCN'=DDGFBKCO!(DDGFBKNN'=DDGFBKNO)!$G(DDGFADD) D
- . D WRITE^DDGLIBW(DDGFWIDB,$J("",$L(DDGFBKNO)),DDGFC1-$P(DDGFLIM,U),DDGFC2-$P(DDGFLIM,U,2),"",1)
- . D WRITE^DDGLIBW(DDGFWIDB,C,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"",1)
- ;
- EDITQ D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
- S:'$G(DDGFADD) DDGFE=1
- K DDGFADD,DDGFBK,DDGFBKCO,DDGFBKNO,DDGFBKCN,DDGFBKNN
- K DDGFC1,DDGFC2,DDGFC3,DDGFDX,DDGFDY
- Q
- ;
- DELETE(B,E) ;Remove block from DDGFREF
- ;E : means don't set DDGFEBV or DDGFBDEL
- ; (used by EDIT^DDGFHBK when a different header block is chosen)
- N F,N
- ;Remove from TMP
- S F="" F S F=$O(@DDGFREF@("F",DDGFPG,B,F)) Q:F="" D
- . S N=@DDGFREF@("F",DDGFPG,B,F)
- . K:$P(N,U,4)]"" @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,3),B)
- . K:$P(N,U,8)>0 @DDGFREF@("RC",DDGFWID,$P(N,U,5),$P(N,U,6),$P(N,U,7),B)
- K @DDGFREF@("F",DDGFPG,B)
- ;
- ;If no blocks on page, set DDGFEBV to exit Block Viewer
- ;DDGFBDEL indicates block name should not be painted
- I $G(DDGFBV) D:'$G(E)
- . I '$P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2),'$O(^(40,0)) S DDGFEBV=1
- . S DDGFBDEL=1
- E D PG^DDGFLOAD(+DDGFFM,+DDGFPG,1,1)
- ;
- ;If used on no other forms, ask whether to delete from block file
- I '$O(^DIST(.403,"AB",B,"")),'$O(^DIST(.403,"AC",B,"")) D
- . K DDGFANS S DDGFBK=B
- . D DDS(.404,"[DDGF BLOCK DELETE]")
- . I $G(DDGFANS) S DIK="^DIST(.404,",DA=DDGFBK D ^DIK K DIK,DA
- . K DDGFANS,DDGFBK
- Q
- ;
- DDS(DDSFILE,DR,DA,DDSPAGE) ;
- ;Call DDS
- S DDSPARM="KTW" D ^DDS K DDSPARM
- 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[HDDGFBK 4512 printed Mar 13, 2025@21:47:03 Page 2
- DDGFBK ;SFISC/MKO-ADD, EDIT, DELETE BLOCK ;2:11 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 ;Add a new block
- +1 NEW B,C1,C2,C3
- +2 SET DDGFDY=DY
- SET DDGFDX=DX
- +3 ;
- +4 ;Invoke form to enter block name
- +5 KILL DDGFBNUM,DDGFBNAM
- +6 DO DDS(.404,"[DDGF BLOCK ADD]")
- +7 if '$DATA(DDGFBNUM)
- GOTO ADDQ
- +8 ;
- +9 ;Ask whether block should be added or indicate duplicate block
- +10 KILL DDGFANS
- +11 SET DDSPAGE=$SELECT($PIECE(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)=DDGFBNUM!$DATA(^(40,"B",DDGFBNUM)):21,1:11)
- +12 DO DDS(.404,"[DDGF BLOCK ADD]","",DDSPAGE)
- +13 if DDSPAGE=21
- GOTO ADDQ
- +14 IF '$GET(DDGFANS)
- Begin DoDot:1
- +15 IF $DATA(^DIST(.404,DDGFBNUM,0))#2
- IF '$PIECE(^(0),U,2)
- Begin DoDot:2
- +16 NEW DIK,DA
- +17 SET DIK="^DIST(.404,"
- SET DA=DDGFBNUM
- +18 DO ^DIK
- End DoDot:2
- End DoDot:1
- GOTO ADDQ
- +19 KILL DDSPAGE,DDGFANS
- +20 ;
- +21 ;Add block to page
- +22 SET DIC="^DIST(.403,+DDGFFM,40,DDGFPG,40,"
- SET DIC(0)="L"
- +23 SET DA(2)=+DDGFFM
- SET DA(1)=DDGFPG
- +24 SET DIC("P")=$PIECE(^DD(.4031,40,0),U,2)
- +25 SET (DINUM,X)=DDGFBNUM
- +26 KILL DO,DD
- DO FILE^DICN
- KILL DINUM,X
- +27 if Y=-1
- GOTO ADDQ
- +28 ;
- +29 ;Stuff in values for block order, coordinates, and type
- +30 SET DIE=DIC
- SET DA=+Y
- +31 SET DDGFC=DDGFDY-$PIECE(DDGFLIM,U)+1_","_(DDGFDX-$PIECE(DDGFLIM,U,2)+1)
- +32 SET DR="1////"_($ORDER(^DIST(.403,+DDGFFM,40,DDGFPG,40,"AC",""),-1)+1\1)_";2////"_DDGFC_";3////e"
- +33 DO ^DIE
- KILL DA,DIC,DIE,DR,X,Y,DDGFC
- +34 ;
- +35 ;If this looks like a brand new block, stuff in DD number
- +36 IF $LENGTH(^DIST(.404,DDGFBNUM,0),U)=1
- IF '$ORDER(^(0))
- Begin DoDot:1
- +37 SET DIE="^DIST(.404,"
- SET DA=DDGFBNUM
- +38 SET DR="1////"_$PIECE(^DIST(.403,+DDGFFM,0),U,8)
- +39 DO ^DIE
- KILL DA,DIE,DR
- End DoDot:1
- +40 ;
- +41 DO BK^DDGFLOAD(DDGFPG,DDGFBNUM,$PIECE(DDGFLIM,U),$PIECE(DDGFLIM,U,2),DDGFDY,DDGFDX,0,1)
- +42 ;
- +43 SET DY=DDGFDY
- SET DX=DDGFDX
- +44 SET B=DDGFBNUM
- SET C=$PIECE(@DDGFREF@("F",DDGFPG,B),U,4)
- +45 SET C1=DY
- SET C2=DX
- SET C3=C2+$LENGTH(DDGFBNAM)-1
- +46 SET DDGFADD=1
- +47 KILL DDGFBNUM,DDGFBNAM
- +48 if $GET(DDGFBV)
- SET DDGFORIG(B)=DY_U_DX
- +49 GOTO EDIT
- +50 ;
- ADDQ ;Adding aborted
- +1 DO REFRESH^DDGF
- DO RC(DDGFDY,DDGFDX)
- +2 KILL DDGFANS,DDGFBNAM,DDGFBNUM,DDGFDX,DDGFDY,DDSPAGE,DA,DIC,Y
- +3 QUIT
- +4 ;
- EDIT ;Edit block
- +1 ;In: B,C1,C2,C3,C
- +2 SET DDGFDY=DY
- SET DDGFDX=DX
- +3 SET DDGFBK=B
- SET DDGFC1=C1
- SET DDGFC2=C2
- SET DDGFC3=C3
- +4 SET DDGFBKCO=C1-$PIECE(DDGFLIM,U)+1_","_(C2-$PIECE(DDGFLIM,U,2)+1)
- +5 SET DDGFBKNO=C
- +6 ;
- +7 ;Invoke form to edit block
- +8 SET DDSFILE=.403
- SET DDSFILE(1)=.4032
- +9 SET DA(2)=+DDGFFM
- SET DA(1)=DDGFPG
- SET DA=B
- +10 SET DR="[DDGF BLOCK EDIT]"
- SET DDSPARM="KTW"
- +11 DO ^DDS
- KILL DDSFILE,DA,DR,DDSPARM
- +12 ;
- +13 ;If block was deleted, remove data from DDGFREF
- +14 IF $DATA(^DIST(.403,+DDGFFM,40,DDGFPG,40,DDGFBK,0))[0
- DO DELETE(DDGFBK)
- GOTO EDITQ
- +15 ;
- +16 if $DATA(DDGFBKCN)[0
- SET DDGFBKCN=DDGFBKCO
- +17 if $DATA(DDGFBKNN)[0
- SET DDGFBKNN=DDGFBKNO
- +18 ;
- +19 SET C=DDGFBKNN
- +20 SET C1=$PIECE(DDGFBKCN,",")-1+$PIECE(DDGFLIM,U)
- +21 SET C2=$PIECE(DDGFBKCN,",",2)-1+$PIECE(DDGFLIM,U,2)
- +22 SET C3=C2+$LENGTH(C)-1
- +23 ;
- +24 ;Update TMP if coordinates or name changed, or new block
- +25 IF DDGFBKCN'=DDGFBKCO!(DDGFBKNN'=DDGFBKNO)!$GET(DDGFADD)
- Begin DoDot:1
- +26 DO WRITE^DDGLIBW(DDGFWIDB,$JUSTIFY("",$LENGTH(DDGFBKNO)),DDGFC1-$PIECE(DDGFLIM,U),DDGFC2-$PIECE(DDGFLIM,U,2),"",1)
- +27 DO WRITE^DDGLIBW(DDGFWIDB,C,C1-$PIECE(DDGFLIM,U),C2-$PIECE(DDGFLIM,U,2),"",1)
- End DoDot:1
- +28 ;
- EDITQ DO REFRESH^DDGF
- DO RC(DDGFDY,DDGFDX)
- +1 if '$GET(DDGFADD)
- SET DDGFE=1
- +2 KILL DDGFADD,DDGFBK,DDGFBKCO,DDGFBKNO,DDGFBKCN,DDGFBKNN
- +3 KILL DDGFC1,DDGFC2,DDGFC3,DDGFDX,DDGFDY
- +4 QUIT
- +5 ;
- DELETE(B,E) ;Remove block from DDGFREF
- +1 ;E : means don't set DDGFEBV or DDGFBDEL
- +2 ; (used by EDIT^DDGFHBK when a different header block is chosen)
- +3 NEW F,N
- +4 ;Remove from TMP
- +5 SET F=""
- FOR
- SET F=$ORDER(@DDGFREF@("F",DDGFPG,B,F))
- if F=""
- QUIT
- Begin DoDot:1
- +6 SET N=@DDGFREF@("F",DDGFPG,B,F)
- +7 if $PIECE(N,U,4)]""
- KILL @DDGFREF@("RC",DDGFWID,$PIECE(N,U),$PIECE(N,U,2),$PIECE(N,U,3),B)
- +8 if $PIECE(N,U,8)>0
- KILL @DDGFREF@("RC",DDGFWID,$PIECE(N,U,5),$PIECE(N,U,6),$PIECE(N,U,7),B)
- End DoDot:1
- +9 KILL @DDGFREF@("F",DDGFPG,B)
- +10 ;
- +11 ;If no blocks on page, set DDGFEBV to exit Block Viewer
- +12 ;DDGFBDEL indicates block name should not be painted
- +13 IF $GET(DDGFBV)
- if '$GET(E)
- Begin DoDot:1
- +14 IF '$PIECE(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)
- IF '$ORDER(^(40,0))
- SET DDGFEBV=1
- +15 SET DDGFBDEL=1
- End DoDot:1
- +16 IF '$TEST
- DO PG^DDGFLOAD(+DDGFFM,+DDGFPG,1,1)
- +17 ;
- +18 ;If used on no other forms, ask whether to delete from block file
- +19 IF '$ORDER(^DIST(.403,"AB",B,""))
- IF '$ORDER(^DIST(.403,"AC",B,""))
- Begin DoDot:1
- +20 KILL DDGFANS
- SET DDGFBK=B
- +21 DO DDS(.404,"[DDGF BLOCK DELETE]")
- +22 IF $GET(DDGFANS)
- SET DIK="^DIST(.404,"
- SET DA=DDGFBK
- DO ^DIK
- KILL DIK,DA
- +23 KILL DDGFANS,DDGFBK
- End DoDot:1
- +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