- DICATTDK ;SFISC/GFT-DELETE FIELD ;25MAY2007
- ;;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.
- ;
- ;FROM ^DICATTDE
- KILL N M,DI,DA,DQ,DICL,D0,DIU,DQI,S,Q,O,X,DICATT4M
- I $D(DDA) S DDA="D" ;'DELETE' flag for Auditing
- S S=";",Q=""""
- MAYBGONE S (A,DA(1))=DICATTA,(D0,DA)=DICATTF I '$D(^DD(A,DA)) Q
- D IJ^DIUTL(A) S DICL=$O(J(""),-1),DQ=""
- F S DQ=$O(^DD(0,.01,"DEL",DQ)) Q:DQ="" I $D(^(DQ,0)) X ^(0) I S DDSERROR=1,DDSBR=1 H 3 G Q ;Delete checks
- S O=^DD(A,D0,0),M=$P(O,U),X=0
- F S X=$O(^DD(A,DA,1,X)) Q:'X I +^(X,0)=DICATTB,$P(^(0),DICATTB,2)?1"^"1.A S DQI=$P(^(0),U,2) ;HMMMMM remember that this field cross-referenced top level
- MUL I $G(DICATT2) D ;Delete a multiple field
- .K ^DD(A,"GL",$P($P(O,U,4),";")) ;SO EN+4^DICATT4 KNOWS TO DELETE THE ENTRIES CORRECTLY
- .S DQ(+DICATT2)=0
- NEW .S DICATT4M(0)=$NA(^DD(A,D0)) ;from NEW^DICATTD4
- .S DICATT4M("SB")=$NA(^DD(A,"SB",+$P(O,U,2),D0))
- .S ^DD(A,D0,0)=O,^DD(A,"SB",+$P(O,U,2),D0)=""
- .D ^DICATT4
- .K @DICATT4M(0),@DICATT4M("SB")
- .D KDD^DICATT4 ;Kill the DD globals below
- ENTRIES E I $P(O,U,2)'["C"," "'[$P(O,U,4) S DICATT4M=1 D ^DICATT4
- D DELFLD(DICATTA,DICATTF)
- D N^DICATTDE
- Q Q
- ;
- DELFLD(DICATTA,DA) ;ALSO FROM ^DICATTD
- W $C(7),!,"FIELD DELETED!" S:$D(DDA) DDA=$E("D",DDA="")
- N A,D0,DIC,DIK,O,M S (DIC,DIK)="^DD(DICATTA,",DA(1)=DICATTA,DA=DICATTF
- AUD S:$D(DDA) ^UTILITY("DDA",$J,DICATTA,DA,0)=$G(^DD(DICATTA,DA,0))
- D ^DIK
- Q
- ;
- ;
- ;
- ;
- POST9 ;POST-ACTION OF FIELD 99, 'ARE YOU SURE YOU WANT TO DELETE THE ENTIRE FIELD?'
- I 'X D Q ;IF THEY DON'T ANSWER "YES", REPAINT FIELD LABEL AND QUIT
- .S X=$P(^DD(DICATTA,DICATTF,0),U)
- .I $G(DICATT2) D PUT^DDSVALF(1,"DICATT MUL",10,X) Q
- .D PUT^DDSVALF(1,"DICATT",1,X)
- S DICATTDK=1,DDACT="EX" ;FORCE EXIT FROM SCREENMAN
- D REQ^DDSUTL(20,"DICATT",1,0)
- NOREQ ;(not sure anyone uses this entry point yet)
- D REQ^DDSUTL(67,"DICATT SCREEN",6,0)
- D REQ^DDSUTL(31,"DICATT2",2.2,0)
- D REQ^DDSUTL(32,"DICATT2",2.2,0)
- D REQ^DDSUTL(68,"DICATT4",2.4,0)
- D REQ^DDSUTL(69,"DICATT4",2.4,0)
- D REQ^DDSUTL(78,"DICATT6",2.6,0)
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATTDK 2330 printed Feb 19, 2025@00:12:04 Page 2
- DICATTDK ;SFISC/GFT-DELETE FIELD ;25MAY2007
- +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 ;
- +7 ;FROM ^DICATTDE
- KILL NEW M,DI,DA,DQ,DICL,D0,DIU,DQI,S,Q,O,X,DICATT4M
- +1 ;'DELETE' flag for Auditing
- IF $DATA(DDA)
- SET DDA="D"
- +2 SET S=";"
- SET Q=""""
- MAYBGONE SET (A,DA(1))=DICATTA
- SET (D0,DA)=DICATTF
- IF '$DATA(^DD(A,DA))
- QUIT
- +1 DO IJ^DIUTL(A)
- SET DICL=$ORDER(J(""),-1)
- SET DQ=""
- +2 ;Delete checks
- FOR
- SET DQ=$ORDER(^DD(0,.01,"DEL",DQ))
- if DQ=""
- QUIT
- IF $DATA(^(DQ,0))
- XECUTE ^(0)
- IF $TEST
- SET DDSERROR=1
- SET DDSBR=1
- HANG 3
- GOTO Q
- +3 SET O=^DD(A,D0,0)
- SET M=$PIECE(O,U)
- SET X=0
- +4 ;HMMMMM remember that this field cross-referenced top level
- FOR
- SET X=$ORDER(^DD(A,DA,1,X))
- if 'X
- QUIT
- IF +^(X,0)=DICATTB
- IF $PIECE(^(0),DICATTB,2)?1"^"1.A
- SET DQI=$PIECE(^(0),U,2)
- MUL ;Delete a multiple field
- IF $GET(DICATT2)
- Begin DoDot:1
- +1 ;SO EN+4^DICATT4 KNOWS TO DELETE THE ENTRIES CORRECTLY
- KILL ^DD(A,"GL",$PIECE($PIECE(O,U,4),";"))
- +2 SET DQ(+DICATT2)=0
- NEW ;from NEW^DICATTD4
- SET DICATT4M(0)=$NAME(^DD(A,D0))
- +1 SET DICATT4M("SB")=$NAME(^DD(A,"SB",+$PIECE(O,U,2),D0))
- +2 SET ^DD(A,D0,0)=O
- SET ^DD(A,"SB",+$PIECE(O,U,2),D0)=""
- +3 DO ^DICATT4
- +4 KILL @DICATT4M(0),@DICATT4M("SB")
- +5 ;Kill the DD globals below
- DO KDD^DICATT4
- End DoDot:1
- ENTRIES IF '$TEST
- IF $PIECE(O,U,2)'["C"
- IF " "'[$PIECE(O,U,4)
- SET DICATT4M=1
- DO ^DICATT4
- +1 DO DELFLD(DICATTA,DICATTF)
- +2 DO N^DICATTDE
- Q QUIT
- +1 ;
- DELFLD(DICATTA,DA) ;ALSO FROM ^DICATTD
- +1 WRITE $CHAR(7),!,"FIELD DELETED!"
- if $DATA(DDA)
- SET DDA=$EXTRACT("D",DDA="")
- +2 NEW A,D0,DIC,DIK,O,M
- SET (DIC,DIK)="^DD(DICATTA,"
- SET DA(1)=DICATTA
- SET DA=DICATTF
- AUD if $DATA(DDA)
- SET ^UTILITY("DDA",$JOB,DICATTA,DA,0)=$GET(^DD(DICATTA,DA,0))
- +1 DO ^DIK
- +2 QUIT
- +3 ;
- +4 ;
- +5 ;
- +6 ;
- POST9 ;POST-ACTION OF FIELD 99, 'ARE YOU SURE YOU WANT TO DELETE THE ENTIRE FIELD?'
- +1 ;IF THEY DON'T ANSWER "YES", REPAINT FIELD LABEL AND QUIT
- IF 'X
- Begin DoDot:1
- +2 SET X=$PIECE(^DD(DICATTA,DICATTF,0),U)
- +3 IF $GET(DICATT2)
- DO PUT^DDSVALF(1,"DICATT MUL",10,X)
- QUIT
- +4 DO PUT^DDSVALF(1,"DICATT",1,X)
- End DoDot:1
- QUIT
- +5 ;FORCE EXIT FROM SCREENMAN
- SET DICATTDK=1
- SET DDACT="EX"
- +6 DO REQ^DDSUTL(20,"DICATT",1,0)
- NOREQ ;(not sure anyone uses this entry point yet)
- +1 DO REQ^DDSUTL(67,"DICATT SCREEN",6,0)
- +2 DO REQ^DDSUTL(31,"DICATT2",2.2,0)
- +3 DO REQ^DDSUTL(32,"DICATT2",2.2,0)
- +4 DO REQ^DDSUTL(68,"DICATT4",2.4,0)
- +5 DO REQ^DDSUTL(69,"DICATT4",2.4,0)
- +6 DO REQ^DDSUTL(78,"DICATT6",2.6,0)
- +7 QUIT
- +8 ;