- DIA3 ;SFISC/GFT-UPDATE POINTERS, CHECK CODE IN INPUT STRING, CHECK FILE ACCESS ;19SEP2004
- ;;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.
- ;
- S Y=DIA("P"),DH=1,DTO=DIA D PTS^DIT:'$D(^UTILITY("DIT",$J,0)) S ^UTILITY("DIT",$J,0)=0 Q:$D(^(0))<9
- D ASK^DITP Q:%-1
- S Y=0 I @("$O("_DIC_"0))'>0") G D
- C W !,"WHICH DO YOU WANT TO DO? --",!?4,"1) DELETE ALL SUCH POINTERS",!?4,"2) CHANGE ALL SUCH POINTERS TO POINT TO A DIFFERENT '"_$P(^(0),U,1)_"' ENTRY",!!,"CHOOSE 1) OR 2): " R %:DTIME G F:U[%,W:%=2,C:%'=1
- D W !,"DELETE ALL POINTERS" D YN^DICN G F:%<0,C:%-1,DITP
- W W !,"THEN PLEASE INDICATE WHICH ENTRY SHOULD BE POINTED TO" D L^DIA2 G DITP:Y>0
- F W $C(7),!,"OK... FORGET IT... LET'S GO ON TO EDIT ANOTHER ENTRY" Q
- DITP S (^UTILITY("DIT",$J,DIA(1)),^(DIA(1)_";"_$E(DIA,2,999)))=+Y_";"_$E(DIA,2,999)
- W !?4,"("_$P("DELETION^RE-POINTING",U,''Y+1)_" WILL OCCUR WHEN YOU LEAVE 'ENTER/EDIT' OPTION)"
- Q
- ;
- FIXPT(DIFLG,DIFILE,DIDELIEN,DIPTIEN) ;DELETE OR REPOINT POINTERS ---never done??
- ;In V21, will just delete pointers. Later, DIPTIEN will be record to repoint to.
- ;DIFLG="D" (delete), DIFILE=File# previously pointed to, DIDELIEN=Record# previously pointed to, DIPTIEN=New pointed-to record(future)
- N %X,%Y,X,Y,DIPTIEN,DIFIXPT,DIFIXPTC,DIFIXPTH D I $G(X)]"" D BLD^DIALOG(201,X) Q
- . S X="DIFLG" Q:$G(DIFLG)'="D" S X="DIDELIEN" Q:'$G(DIDELIEN) S X="DIFILE" Q:'$G(DIFILE) Q:$G(^DIC(DIFILE,0,"GL"))=""
- . S X="DIPTIEN" I $G(DIPTIEN) S Y=$G(^DD(DIFILE,0,"GL")) Q:Y="" I '$D(@(Y_DIPTIEN_",0)")) Q ;<<<Kevin T found bad code 11/14/05
- . K X Q
- S DIPTIEN=+$G(DIPTIEN),(DIFIXPT,DIFIXPTC)=1
- N %,BY,D,DHD,DHIT,DIA,DIC,DISTOP,DL,DR,DTO,FLDS,FR,IOP,L,TO,X,Y,Z K ^UTILITY("DIT",$J),^TMP("DIFIXPT",$J)
- S (DIFILE,DIA("P"),Y)=+DIFILE,(DIA,DTO)=^DIC(DIFILE,0,"GL"),DIA(1)=DIDELIEN
- D PTS^DIT S ^UTILITY("DIT",$J,0)=0 G:$D(^(0))<9 QFIXPT
- S (^UTILITY("DIT",$J,DIA(1)),^(DIA(1)_";"_$E(DIA,2,999)))=DIPTIEN_";"_$E(DIA,2,999)
- D P^DITP
- QFIXPT K ^UTILITY("DIT",$J),DIFLG,DIFILE,DIDELIEN,DIIOP,DIPTIEN Q
- ;
- X ;
- I 'Y S:'DSC&DB DB=DB+1 S Y=0 F S Y=$O(Y(Y)) D D^DIA:Y'="" I Y="" S Y=-1 G 2^DIA
- S Y=X I DUZ(0)="@",X'?.E1":" S X=$S(X["//^":$P(X,"//^",2),1:X),X=$S(X[";":$P(X,";"),1:X) D ^DIM G:$D(X) P^DIA:X=Y I Y["//^",'$D(X) G BAD
- I Y[";" F %=2:1 S D=$P(Y,";",%) Q:D="" S D=$S(D="DUP":"d",D="REQ":"R","""R""d"""[D:"",$A(D)=34:$E(D,2,$F(D,"""",2)-2),D="T":D,1:"") G BAD:D="",DIA3^DIQQQ:$A(D)>45&($A(D)<58)!(D[":") S DV=D_$C(126)_DV
- I Y[";" S X=$P(Y,";",1) S:'$D(DIAB) DIAB=Y G DIC^DIA
- F DK="///+","//+","///","//" I Y[DK S DP=$P(Y,DK,2,9) I DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@") G DEF
- G BAD:Y'?.E1":"
- E K X S:'$D(DIAB) DIAB=Y S DICOMP=L_"WE?",DQI="Y(",DA="DR(99,"_DXS_",",X=Y,DICMX=1 D ^DICOMPW I '$D(X) K DIAB G BAD:'$D(DP),ACC
- L I $D(X)>1 S DXS=DXS+1,%=0 F S %=$O(X(%)) Q:%="" S @(DA_"%)=X(%)")
- S %=-1 S L=$S(Y>L:+Y,1:L\100+1*100),Y=U_DP_U_U_X_" S X=$S(D(0)>0:D(0),1:"""")",DRS=99 K X D DB^DIA S DI=+DP G FILETOP^DIA
- ;
- DEF S X="DA,DV,DWLC,0)=X" F J=L:-1 Q:I(J)[U S X="DA("_(L-J+1)_"),"_I(J)_","_X
- S DICMX="S DWLC=DWLC+1,"_DIA_X,DA="DR(99,"_DXS_",",DHIT=Y,X=DP,DQI="X(",DICOMP=L_"T?" D EN^DICOMP,DICS^DIA,XEC K X S X=$P(DHIT,DK,1),DV=DV_DK_DP G DIC^DIA:DV'[";"
- BAD Q:$D(DTOUT) G X^DIA
- ACC K DIAB W !?9,"YOU HAVE NO WRITE ACCESS TO FILE "_+DP G BAD
- Q
- ;
- XEC I $D(X),Y["m" S DIC("S")="S %=$P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S")
- S Y=0 F S Y=$O(X(Y)) Q:Y="" S @(DA_"Y)=X(Y)")
- S Y=-1 I $D(X) S %=1,Y="DO YOU MEAN '"_DP_"' AS A VARIABLE" W !?63-$L(Y),Y D YN^DICN Q:%-1 S Y="Q",DXS=DXS+1,DP=U_X,DRS=99 D D^DIA:$S(DIAP:$P(DR(F+1,DI),";",DIAP#1000)'="Q",1:1) S:'$D(DIAB) DIAB=DHIT
- Q:DP'="@" I DK="//" S DA=U_U Q
- W !,$C(7)," WARNING: THIS MEANS AUTOMATIC DELETION!!"
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIA3 4014 printed Mar 13, 2025@21:49:19 Page 2
- DIA3 ;SFISC/GFT-UPDATE POINTERS, CHECK CODE IN INPUT STRING, CHECK FILE ACCESS ;19SEP2004
- +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 SET Y=DIA("P")
- SET DH=1
- SET DTO=DIA
- if '$DATA(^UTILITY("DIT",$JOB,0))
- DO PTS^DIT
- SET ^UTILITY("DIT",$JOB,0)=0
- if $DATA(^(0))<9
- QUIT
- +8 DO ASK^DITP
- if %-1
- QUIT
- +9 SET Y=0
- IF @("$O("_DIC_"0))'>0")
- GOTO D
- C WRITE !,"WHICH DO YOU WANT TO DO? --",!?4,"1) DELETE ALL SUCH POINTERS",!?4,"2) CHANGE ALL SUCH POINTERS TO POINT TO A DIFFERENT '"_$PIECE(^(0),U,1)_"' ENTRY",!!,"CHOOSE 1) OR 2): "
- READ %:DTIME
- if U[%
- GOTO F
- if %=2
- GOTO W
- if %'=1
- GOTO C
- D WRITE !,"DELETE ALL POINTERS"
- DO YN^DICN
- if %<0
- GOTO F
- if %-1
- GOTO C
- GOTO DITP
- W WRITE !,"THEN PLEASE INDICATE WHICH ENTRY SHOULD BE POINTED TO"
- DO L^DIA2
- if Y>0
- GOTO DITP
- F WRITE $CHAR(7),!,"OK... FORGET IT... LET'S GO ON TO EDIT ANOTHER ENTRY"
- QUIT
- DITP SET (^UTILITY("DIT",$JOB,DIA(1)),^(DIA(1)_";"_$EXTRACT(DIA,2,999)))=+Y_";"_$EXTRACT(DIA,2,999)
- +1 WRITE !?4,"("_$PIECE("DELETION^RE-POINTING",U,''Y+1)_" WILL OCCUR WHEN YOU LEAVE 'ENTER/EDIT' OPTION)"
- +2 QUIT
- +3 ;
- FIXPT(DIFLG,DIFILE,DIDELIEN,DIPTIEN) ;DELETE OR REPOINT POINTERS ---never done??
- +1 ;In V21, will just delete pointers. Later, DIPTIEN will be record to repoint to.
- +2 ;DIFLG="D" (delete), DIFILE=File# previously pointed to, DIDELIEN=Record# previously pointed to, DIPTIEN=New pointed-to record(future)
- +3 NEW %X,%Y,X,Y,DIPTIEN,DIFIXPT,DIFIXPTC,DIFIXPTH
- Begin DoDot:1
- +4 SET X="DIFLG"
- if $GET(DIFLG)'="D"
- QUIT
- SET X="DIDELIEN"
- if '$GET(DIDELIEN)
- QUIT
- SET X="DIFILE"
- if '$GET(DIFILE)
- QUIT
- if $GET(^DIC(DIFILE,0,"GL"))=""
- QUIT
- +5 ;<<<Kevin T found bad code 11/14/05
- SET X="DIPTIEN"
- IF $GET(DIPTIEN)
- SET Y=$GET(^DD(DIFILE,0,"GL"))
- if Y=""
- QUIT
- IF '$DATA(@(Y_DIPTIEN_",0)"))
- QUIT
- +6 KILL X
- QUIT
- End DoDot:1
- IF $GET(X)]""
- DO BLD^DIALOG(201,X)
- QUIT
- +7 SET DIPTIEN=+$GET(DIPTIEN)
- SET (DIFIXPT,DIFIXPTC)=1
- +8 NEW %,BY,D,DHD,DHIT,DIA,DIC,DISTOP,DL,DR,DTO,FLDS,FR,IOP,L,TO,X,Y,Z
- KILL ^UTILITY("DIT",$JOB),^TMP("DIFIXPT",$JOB)
- +9 SET (DIFILE,DIA("P"),Y)=+DIFILE
- SET (DIA,DTO)=^DIC(DIFILE,0,"GL")
- SET DIA(1)=DIDELIEN
- +10 DO PTS^DIT
- SET ^UTILITY("DIT",$JOB,0)=0
- if $DATA(^(0))<9
- GOTO QFIXPT
- +11 SET (^UTILITY("DIT",$JOB,DIA(1)),^(DIA(1)_";"_$EXTRACT(DIA,2,999)))=DIPTIEN_";"_$EXTRACT(DIA,2,999)
- +12 DO P^DITP
- QFIXPT KILL ^UTILITY("DIT",$JOB),DIFLG,DIFILE,DIDELIEN,DIIOP,DIPTIEN
- QUIT
- +1 ;
- X ;
- +1 IF 'Y
- if 'DSC&DB
- SET DB=DB+1
- SET Y=0
- FOR
- SET Y=$ORDER(Y(Y))
- if Y'=""
- DO D^DIA
- IF Y=""
- SET Y=-1
- GOTO 2^DIA
- +2 SET Y=X
- IF DUZ(0)="@"
- IF X'?.E1":"
- SET X=$SELECT(X["//^":$PIECE(X,"//^",2),1:X)
- SET X=$SELECT(X[";":$PIECE(X,";"),1:X)
- DO ^DIM
- if $DATA(X)
- if X=Y
- GOTO P^DIA
- IF Y["//^"
- IF '$DATA(X)
- GOTO BAD
- +3 IF Y[";"
- FOR %=2:1
- SET D=$PIECE(Y,";",%)
- if D=""
- QUIT
- SET D=$SELECT(D="DUP":"d",D="REQ":"R","""R""d"""[D:"",$ASCII(D)=34:$EXTRACT(D,2,$FIND(D,"""",2)-2),D="T":D,1:"")
- if D=""
- GOTO BAD
- if $ASCII(D)>45&($ASCII(D)<58)!(D[":")
- GOTO DIA3^DIQQQ
- SET DV=D_$CHAR(126)_DV
- +4 IF Y[";"
- SET X=$PIECE(Y,";",1)
- if '$DATA(DIAB)
- SET DIAB=Y
- GOTO DIC^DIA
- +5 FOR DK="///+","//+","///","//"
- IF Y[DK
- SET DP=$PIECE(Y,DK,2,9)
- IF DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@")
- GOTO DEF
- +6 if Y'?.E1":"
- GOTO BAD
- E KILL X
- if '$DATA(DIAB)
- SET DIAB=Y
- SET DICOMP=L_"WE?"
- SET DQI="Y("
- SET DA="DR(99,"_DXS_","
- SET X=Y
- SET DICMX=1
- DO ^DICOMPW
- IF '$DATA(X)
- KILL DIAB
- if '$DATA(DP)
- GOTO BAD
- GOTO ACC
- L IF $DATA(X)>1
- SET DXS=DXS+1
- SET %=0
- FOR
- SET %=$ORDER(X(%))
- if %=""
- QUIT
- SET @(DA_"%)=X(%)")
- +1 SET %=-1
- SET L=$SELECT(Y>L:+Y,1:L\100+1*100)
- SET Y=U_DP_U_U_X_" S X=$S(D(0)>0:D(0),1:"""")"
- SET DRS=99
- KILL X
- DO DB^DIA
- SET DI=+DP
- GOTO FILETOP^DIA
- +2 ;
- DEF SET X="DA,DV,DWLC,0)=X"
- FOR J=L:-1
- if I(J)[U
- QUIT
- SET X="DA("_(L-J+1)_"),"_I(J)_","_X
- +1 SET DICMX="S DWLC=DWLC+1,"_DIA_X
- SET DA="DR(99,"_DXS_","
- SET DHIT=Y
- SET X=DP
- SET DQI="X("
- SET DICOMP=L_"T?"
- DO EN^DICOMP
- DO DICS^DIA
- DO XEC
- KILL X
- SET X=$PIECE(DHIT,DK,1)
- SET DV=DV_DK_DP
- if DV'[";"
- GOTO DIC^DIA
- BAD if $DATA(DTOUT)
- QUIT
- GOTO X^DIA
- ACC KILL DIAB
- WRITE !?9,"YOU HAVE NO WRITE ACCESS TO FILE "_+DP
- GOTO BAD
- +1 QUIT
- +2 ;
- XEC IF $DATA(X)
- IF Y["m"
- SET DIC("S")="S %=$P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S")
- +1 SET Y=0
- FOR
- SET Y=$ORDER(X(Y))
- if Y=""
- QUIT
- SET @(DA_"Y)=X(Y)")
- +2 SET Y=-1
- IF $DATA(X)
- SET %=1
- SET Y="DO YOU MEAN '"_DP_"' AS A VARIABLE"
- WRITE !?63-$LENGTH(Y),Y
- DO YN^DICN
- if %-1
- QUIT
- SET Y="Q"
- SET DXS=DXS+1
- SET DP=U_X
- SET DRS=99
- if $SELECT(DIAP:$PIECE(DR(F+1,DI),";",DIAP#1000)'="Q",1:1)
- DO D^DIA
- if '$DATA(DIAB)
- SET DIAB=DHIT
- +3 if DP'="@"
- QUIT
- IF DK="//"
- SET DA=U_U
- QUIT
- +4 WRITE !,$CHAR(7)," WARNING: THIS MEANS AUTOMATIC DELETION!!"
