DIA2 ;SFISC/GFT-SELECT ENTRY TO EDIT, ^LOOP ;16MAY2007
;;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.
;
K ^UTILITY("DIT",$J),DA,DRS,DW,DIAP,DI I '$D(DR(1,J(0))) S DR(1,J(0))=".01:99999999"
I $L(DR(1,J(0)))+$L(DIA)<216,+DR(1,J(0))=.01 S DR(1,J(0))="S:DIA(9) DQ=2,X=$P("_DIA_"DA,0),U,1);"_DR(1,J(0))
DIC W !! G Q^DIB:$D(DTOUT) D L S DIA(1)=+Y,DIA(9)=$P(Y,U,3) I Y>0 D DIE,^DIA3:'$D(DA) G DIC
I X'["LOOP",X'["loop" D PTS^DITP:$O(^UTILITY("DIT",$J,0))>0 K ^UTILITY("DIT",$J) G Q^DIB
S L="EDIT ENTRIES",DHD="@",IOP="HOME",FLDS="",DHIT="S DCC="""_$$CONVQQ^DILIBF(DIA)_""" D LOOP^DIA2 S:'$D(DCC) DN=0" D EN1^DIP W !!?4,"LOOP ENDED!" Q:$D(DTOUT) G DIC
;
L K Y,I,J,F,DIC S (DIC,DIE)=DIA,DIC(0)="QEALM" D K DIE S DIE=DIA Q
.N DIA,DR D ^DIC ;could go to a custom lookup that deranges these variables
;
DIE S DP=DIA("P"),DA=+Y,DR=DR(1,DP)
K DIC,Y,C,DB S DIC=DIE,DILK=DIE_DA_")" D LOCK^DILF(DILK) ;**147
E W $C(7),!,"ANOTHER TERMINAL IS EDITING THIS ENTRY!" K DILK Q
I DR?1"^".AN D @DR L @("-"_DILK) K DILK Q
E D GO^DIE L @("-"_DILK) K DILK Q
;
LOOP ;DELETE OR REPLACE POINTERS
G NUL:$D(@(DCC_D0_",-9)")) I '($G(DIFIXPT)=1) W !!,?3
S X=$P(@(DCC_"0)"),U,2) G NUL:'$D(^(D0,0)) S (DI,Y)=$P(^(0),U,1),C=$P(^DD(+X,.01,0),U,2)
D
. N X D Y^DIQ
I $G(DIFIXPT)=1 D
. I $D(DIFIXPTH) S ^TMP("DIFIXPT",$J,DIFIXPTC)=DIFIXPTH,DIFIXPTC=DIFIXPTC+1 K DIFIXPTH
. S ^TMP("DIFIXPT",$J,DIFIXPTC)=" Entry:"_D0_"-"_$E(Y,1,20)_" "
. Q
I '($G(DIFIXPT)=1) W Y
S Y=D0,(DIE,DIC)=DCC,%C=0
I X["I",'($G(DIFIXPT)=1) S %Y=0 F S %C=$O(^DD(+X,0,"ID",%C)) Q:%C="" S %=^(%C) D
. N DIQUIET
. W " ",$E(@(DCC_"Y,0)"),0) X %
K DO S %C=-1,DO(2)=X,Y=Y_U_DI,DIC(0)=$P("E^",U,('($G(DIFIXPT)=1))) D ACT^DICM1 S DI=99 K DO,DIY Q:Y<0
S Y=D0 D DIE S:$G(DIFIXPT) DIFIXPTC=DIFIXPTC+1 I $D(DTOUT) K DCC,Y
I $D(Y) K Y I '($G(DIFIXPT)=1) S %=1 W $C(7),!!,"WANT TO STOP LOOPING" D YN^DICN I %-2 K DCC
NUL S DI=99,(^UTILITY($J,99,0),DX(0))="Q" K D1,D2,D3,D4,D5
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIA2 2230 printed Jan 18, 2025@03:45:33 Page 2
DIA2 ;SFISC/GFT-SELECT ENTRY TO EDIT, ^LOOP ;16MAY2007
+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 KILL ^UTILITY("DIT",$JOB),DA,DRS,DW,DIAP,DI
IF '$DATA(DR(1,J(0)))
SET DR(1,J(0))=".01:99999999"
+8 IF $LENGTH(DR(1,J(0)))+$LENGTH(DIA)<216
IF +DR(1,J(0))=.01
SET DR(1,J(0))="S:DIA(9) DQ=2,X=$P("_DIA_"DA,0),U,1);"_DR(1,J(0))
DIC WRITE !!
if $DATA(DTOUT)
GOTO Q^DIB
DO L
SET DIA(1)=+Y
SET DIA(9)=$PIECE(Y,U,3)
IF Y>0
DO DIE
if '$DATA(DA)
DO ^DIA3
GOTO DIC
+1 IF X'["LOOP"
IF X'["loop"
if $ORDER(^UTILITY("DIT",$JOB,0))>0
DO PTS^DITP
KILL ^UTILITY("DIT",$JOB)
GOTO Q^DIB
+2 SET L="EDIT ENTRIES"
SET DHD="@"
SET IOP="HOME"
SET FLDS=""
SET DHIT="S DCC="""_$$CONVQQ^DILIBF(DIA)_""" D LOOP^DIA2 S:'$D(DCC) DN=0"
DO EN1^DIP
WRITE !!?4,"LOOP ENDED!"
if $DATA(DTOUT)
QUIT
GOTO DIC
+3 ;
L KILL Y,I,J,F,DIC
SET (DIC,DIE)=DIA
SET DIC(0)="QEALM"
Begin DoDot:1
+1 ;could go to a custom lookup that deranges these variables
NEW DIA,DR
DO ^DIC
End DoDot:1
KILL DIE
SET DIE=DIA
QUIT
+2 ;
DIE SET DP=DIA("P")
SET DA=+Y
SET DR=DR(1,DP)
+1 ;**147
KILL DIC,Y,C,DB
SET DIC=DIE
SET DILK=DIE_DA_")"
DO LOCK^DILF(DILK)
+2 IF '$TEST
WRITE $CHAR(7),!,"ANOTHER TERMINAL IS EDITING THIS ENTRY!"
KILL DILK
QUIT
+3 IF DR?1"^".AN
DO @DR
LOCK @("-"_DILK)
KILL DILK
QUIT
+4 IF '$TEST
DO GO^DIE
LOCK @("-"_DILK)
KILL DILK
QUIT
+5 ;
LOOP ;DELETE OR REPLACE POINTERS
+1 if $DATA(@(DCC_D0_",-9)"))
GOTO NUL
IF '($GET(DIFIXPT)=1)
WRITE !!,?3
+2 SET X=$PIECE(@(DCC_"0)"),U,2)
if '$DATA(^(D0,0))
GOTO NUL
SET (DI,Y)=$PIECE(^(0),U,1)
SET C=$PIECE(^DD(+X,.01,0),U,2)
+3 Begin DoDot:1
+4 NEW X
DO Y^DIQ
End DoDot:1
+5 IF $GET(DIFIXPT)=1
Begin DoDot:1
+6 IF $DATA(DIFIXPTH)
SET ^TMP("DIFIXPT",$JOB,DIFIXPTC)=DIFIXPTH
SET DIFIXPTC=DIFIXPTC+1
KILL DIFIXPTH
+7 SET ^TMP("DIFIXPT",$JOB,DIFIXPTC)=" Entry:"_D0_"-"_$EXTRACT(Y,1,20)_" "
+8 QUIT
End DoDot:1
+9 IF '($GET(DIFIXPT)=1)
WRITE Y
+10 SET Y=D0
SET (DIE,DIC)=DCC
SET %C=0
+11 IF X["I"
IF '($GET(DIFIXPT)=1)
SET %Y=0
FOR
SET %C=$ORDER(^DD(+X,0,"ID",%C))
if %C=""
QUIT
SET %=^(%C)
Begin DoDot:1
+12 NEW DIQUIET
+13 WRITE " ",$EXTRACT(@(DCC_"Y,0)"),0)
XECUTE %
End DoDot:1
+14 KILL DO
SET %C=-1
SET DO(2)=X
SET Y=Y_U_DI
SET DIC(0)=$PIECE("E^",U,('($GET(DIFIXPT)=1)))
DO ACT^DICM1
SET DI=99
KILL DO,DIY
if Y<0
QUIT
+15 SET Y=D0
DO DIE
if $GET(DIFIXPT)
SET DIFIXPTC=DIFIXPTC+1
IF $DATA(DTOUT)
KILL DCC,Y
+16 IF $DATA(Y)
KILL Y
IF '($GET(DIFIXPT)=1)
SET %=1
WRITE $CHAR(7),!!,"WANT TO STOP LOOPING"
DO YN^DICN
IF %-2
KILL DCC
NUL SET DI=99
SET (^UTILITY($JOB,99,0),DX(0))="Q"
KILL D1,D2,D3,D4,D5
+1 QUIT
