- DICOMPV ;SFISC/GFT - BACKWARD-POINTERS IN COMPUTED FIELDS ;13APR2007
- ;;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.
- ;
- N DIX,DICOTRY,DICOLEV
- D DRW^DICOMPX
- TRY F DICOTRY=1,2 S Y=$$BACK I Y[U Q:Y=U D:$G(D)-.001 Y^DICOMPX G END
- S D=0 ;'D' is a flag to the calling routine, DICOMP0, saying we've found nothing here in DICOMPV
- END Q
- ;
- BACK() N DICOB,DICODD
- S DICOB=DLV0,DICODD=0
- DD S DICODD=$O(^DD(J(DICOB),0,"PT",DICODD)) I DICODD'>0 S DICOB=DICOB-100,DICODD=0 G DD:DICOB'<0 Q ""
- ARCH S Y=DICODD I DICOMP["W",$P($G(^DD(Y,0,"DI")),U,2)["Y" G DD ;No editing RESTRICTED or ARCHIVE file!
- F DICOLEV=0:-1 G DD:'$D(^DD(Y,0)) Q:'$D(^(0,"UP")) S Y=^("UP")
- I $D(^DIC(Y,0)),$P(^(0),X)="" X DIC("S") I $T,$D(^DIC(Y,0,"GL")) S V=^("GL"),D=0 F S D=$O(^DD(J(DICOB),0,"PT",DICODD,D)) Q:'D D G Y:Y[U
- DINUM .I DICODD=Y,D=.01&(DICOTRY=1)&($P($G(^DD(Y,.01,0)),U,5,99)["DINUM=X")!(D=.001&(DICOTRY=2)) D YN("") I %=1 S %Y=V,X="D0" S:$D(DIFG) DIFG=1 D X(Y,D),P^DICOMPX S D=.001,Y=Y_U Q
- .Q:'$D(DICMX) ;Stop if expression can't be multiple-valued
- .N DICOUT F DIX=0:0 S DIX=$O(^DD(DICODD,D,1,DIX)) Q:DIX'>0 S J=$G(^(DIX,0)) I +J=Y S %=$P(J,U,3,9) I $S(DICOTRY=1:%="",1:%]""&("MUMPS"[%)) D G:$G(DICOUT) Q
- ..D YN("Cross-reference") I %<1 S Y=U,DICOUT=1 Q
- ..I %=1 D MP S DICOUT=1
- .Q:DICOTRY=1
- INDEXES .F DIX=0:0 S DIX=$O(^DD("IX","F",DICODD,D,DIX)) Q:'DIX I $P($G(^DD("IX",DIX,0)),U,4)="R",$P(^(0),U,9)=DICODD S J=$P(^(0),U,1,3) I +J=Y,$P($G(^(11.1,1,0)),U,2,4)=("F^"_DICODD_U_D) D YN("Index") G Q:%<1 I %=1 D MP G Q
- Q .Q
- G DD
- ;
- Y Q Y
- ;
- ;
- MP S DICN=$S(DA:DQI_(80+DICOB),1:"I("_DICOB_",0")_")",J=""""_$P(J,U,2)_"""",T=D S:$D(DIFG) DIFG=$P(J,"""",2)
- I DICOMP'["W" D G POP:$D(Y) S (Y,D)=0 Q
- .N DICOMPIX S DICOMPIX=J
- .S D=Y,I(DLV0+100)=V,J(DLV0+100)=D
- RCR .D BACKPNT^DICOMPZ Q:'$D(Y)
- .S Y=D,X=$P(^DD(D,.01,0),U,2) D X^DICOMPZ
- .S D="S (D,D0)=$QS(DIMQ,$QL(DIMQ)" I DICOLEV S D=D_DICOLEV
- .D DIMP^DICOMPZ(D_") I D,$D("_V_"D,0)) "_X_" "_DICMX)
- .D DIMP^DICOMPZ("N DIMQ,DIMSTRT,DIMSCNT S (DIMQ,DIMSTRT)=$NA("_V_DICOMPIX_","_DICN_")),DIMSCNT=$QL(DIMQ) F S DIMQ=$Q(@DIMQ) Q:DIMQ="""" Q:$NA(@DIMQ,DIMSCNT)'=DIMSTRT "_X_" Q:'$D(D) S D=D0")
- .S X=X_" S X="""""
- ASK D ASKE^DICOMPW I 'D,T-.01&'DS!(DICODD-Y) S D=0
- E S DZ=0 D ASK^DICOMPW:'D I D<0 K T Q
- S %=D,D="N DIADD,DIC S DIC="_Y_$S(%=2:",DIADD=1",1:"")_",DIC(0)="""_$P("EQ",U,DS)_$E("L",D>0)_$E("W",$D(DICO(3)))
- CROSS I T-.01 S D=D_$P("AM",U,DS)_""",DIC(""S"")=""I $D("_V_""""_J_""","""_"_"_DICN_"_"_""",Y))"" D ^DIC S D0=+Y,DIC("_T_")="_DICN_",DIH="_Y_" D DICL^DICR:$P(Y,U,3)"
- E S D=D_"U"",X="_DICN_" D ^DIC S D0=+Y"
- DIM D DIMP^DICOMPZ(D) I '% S %=":$O(^(D0))>0",X=" S D0=$O("_V_J_","_DICN_",0))"_$S(DS:X_%,1:" S"_%_" D0=0")
- S X=X_" S X=$S(D0>0:D0,1:"""")" S:$D(DICOMPX(0)) X=X_","_DICOMPX(0)_"0)=X"
- POP S Y=Y_U,D=1,DICO("PT")=+Y
- D X(+Y,.01) Q
- ;
- X(Y,D) S DICN=Y ;Remember that we have used this field
- I $D(DICOMPX)#2 S DICOMPX=Y_U_D_$E(";",1,$L(DICOMPX))_DICOMPX
- Q
- ;
- YN(SHOW) N X
- S X=$P(^DIC(Y,0),U)
- S %=1 I DICOMP["?" D
- YOU .N N ;**CCO/NI (+ next 2 lines) 'BY SO&SO, DO YOU MEAN THE SUCH&SUCH FILE, POINTING...?'
- .S N(1)=DICN,N(2)=X,N(3)=$P(^DD(DICODD,D,0),U),DICV=$P(^(0),U,2)
- .W !,$$EZBLD^DIALOG(8202,.N)
- .I SHOW]"" W !," (""",$P(J,U,2),""" ",SHOW,")"
- .D YN^DICN
- I %=1 F M=M:1:$L(I)+1 Q:$F(X,$E(I,1,M))-1-M S W=$E(I,M+1)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICOMPV 3611 printed Jan 18, 2025@03:47:27 Page 2
- DICOMPV ;SFISC/GFT - BACKWARD-POINTERS IN COMPUTED FIELDS ;13APR2007
- +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 NEW DIX,DICOTRY,DICOLEV
- +8 DO DRW^DICOMPX
- TRY FOR DICOTRY=1,2
- SET Y=$$BACK
- IF Y[U
- if Y=U
- QUIT
- if $GET(D)-.001
- DO Y^DICOMPX
- GOTO END
- +1 ;'D' is a flag to the calling routine, DICOMP0, saying we've found nothing here in DICOMPV
- SET D=0
- END QUIT
- +1 ;
- BACK() NEW DICOB,DICODD
- +1 SET DICOB=DLV0
- SET DICODD=0
- DD SET DICODD=$ORDER(^DD(J(DICOB),0,"PT",DICODD))
- IF DICODD'>0
- SET DICOB=DICOB-100
- SET DICODD=0
- if DICOB'<0
- GOTO DD
- QUIT ""
- ARCH ;No editing RESTRICTED or ARCHIVE file!
- SET Y=DICODD
- IF DICOMP["W"
- IF $PIECE($GET(^DD(Y,0,"DI")),U,2)["Y"
- GOTO DD
- +1 FOR DICOLEV=0:-1
- if '$DATA(^DD(Y,0))
- GOTO DD
- if '$DATA(^(0,"UP"))
- QUIT
- SET Y=^("UP")
- +2 IF $DATA(^DIC(Y,0))
- IF $PIECE(^(0),X)=""
- XECUTE DIC("S")
- IF $TEST
- IF $DATA(^DIC(Y,0,"GL"))
- SET V=^("GL")
- SET D=0
- FOR
- SET D=$ORDER(^DD(J(DICOB),0,"PT",DICODD,D))
- if 'D
- QUIT
- Begin DoDot:1
- DINUM IF DICODD=Y
- IF D=.01&(DICOTRY=1)&($PIECE($GET(^DD(Y,.01,0)),U,5,99)["DINUM=X")!(D=.001&(DICOTRY=2))
- DO YN("")
- IF %=1
- SET %Y=V
- SET X="D0"
- if $DATA(DIFG)
- SET DIFG=1
- DO X(Y,D)
- DO P^DICOMPX
- SET D=.001
- SET Y=Y_U
- QUIT
- +1 ;Stop if expression can't be multiple-valued
- if '$DATA(DICMX)
- QUIT
- +2 NEW DICOUT
- FOR DIX=0:0
- SET DIX=$ORDER(^DD(DICODD,D,1,DIX))
- if DIX'>0
- QUIT
- SET J=$GET(^(DIX,0))
- IF +J=Y
- SET %=$PIECE(J,U,3,9)
- IF $SELECT(DICOTRY=1:%="",1:%]""&("MUMPS"[%))
- Begin DoDot:2
- +3 DO YN("Cross-reference")
- IF %<1
- SET Y=U
- SET DICOUT=1
- QUIT
- +4 IF %=1
- DO MP
- SET DICOUT=1
- End DoDot:2
- if $GET(DICOUT)
- GOTO Q
- +5 if DICOTRY=1
- QUIT
- INDEXES FOR DIX=0:0
- SET DIX=$ORDER(^DD("IX","F",DICODD,D,DIX))
- if 'DIX
- QUIT
- IF $PIECE($GET(^DD("IX",DIX,0)),U,4)="R"
- IF $PIECE(^(0),U,9)=DICODD
- SET J=$PIECE(^(0),U,1,3)
- IF +J=Y
- IF $PIECE($GET(^(11.1,1,0)),U,2,4)=("F^"_DICODD_U_D)
- DO YN("Index")
- if %<1
- GOTO Q
- IF %=1
- DO MP
- GOTO Q
- Q QUIT
- End DoDot:1
- if Y[U
- GOTO Y
- +1 GOTO DD
- +2 ;
- Y QUIT Y
- +1 ;
- +2 ;
- MP SET DICN=$SELECT(DA:DQI_(80+DICOB),1:"I("_DICOB_",0")_")"
- SET J=""""_$PIECE(J,U,2)_""""
- SET T=D
- if $DATA(DIFG)
- SET DIFG=$PIECE(J,"""",2)
- +1 IF DICOMP'["W"
- Begin DoDot:1
- +2 NEW DICOMPIX
- SET DICOMPIX=J
- +3 SET D=Y
- SET I(DLV0+100)=V
- SET J(DLV0+100)=D
- RCR DO BACKPNT^DICOMPZ
- if '$DATA(Y)
- QUIT
- +1 SET Y=D
- SET X=$PIECE(^DD(D,.01,0),U,2)
- DO X^DICOMPZ
- +2 SET D="S (D,D0)=$QS(DIMQ,$QL(DIMQ)"
- IF DICOLEV
- SET D=D_DICOLEV
- +3 DO DIMP^DICOMPZ(D_") I D,$D("_V_"D,0)) "_X_" "_DICMX)
- +4 DO DIMP^DICOMPZ("N DIMQ,DIMSTRT,DIMSCNT S (DIMQ,DIMSTRT)=$NA("_V_DICOMPIX_","_DICN_")),DIMSCNT=$QL(DIMQ) F S DIMQ=$Q(@DIMQ) Q:DIMQ="""" Q:$NA(@DIMQ,DIMSCNT)'=DIMSTRT "_X_" Q:'$D(D) S D=D0")
- +5 SET X=X_" S X="""""
- End DoDot:1
- if $DATA(Y)
- GOTO POP
- SET (Y,D)=0
- QUIT
- ASK DO ASKE^DICOMPW
- IF 'D
- IF T-.01&'DS!(DICODD-Y)
- SET D=0
- +1 IF '$TEST
- SET DZ=0
- if 'D
- DO ASK^DICOMPW
- IF D<0
- KILL T
- QUIT
- +2 SET %=D
- SET D="N DIADD,DIC S DIC="_Y_$SELECT(%=2:",DIADD=1",1:"")_",DIC(0)="""_$PIECE("EQ",U,DS)_$EXTRACT("L",D>0)_$EXTRACT("W",$DATA(DICO(3)))
- CROSS IF T-.01
- SET D=D_$PIECE("AM",U,DS)_""",DIC(""S"")=""I $D("_V_""""_J_""","""_"_"_DICN_"_"_""",Y))"" D ^DIC S D0=+Y,DIC("_T_")="_DICN_",DIH="_Y_" D DICL^DICR:$P(Y,U,3)"
- +1 IF '$TEST
- SET D=D_"U"",X="_DICN_" D ^DIC S D0=+Y"
- DIM DO DIMP^DICOMPZ(D)
- IF '%
- SET %=":$O(^(D0))>0"
- SET X=" S D0=$O("_V_J_","_DICN_",0))"_$SELECT(DS:X_%,1:" S"_%_" D0=0")
- +1 SET X=X_" S X=$S(D0>0:D0,1:"""")"
- if $DATA(DICOMPX(0))
- SET X=X_","_DICOMPX(0)_"0)=X"
- POP SET Y=Y_U
- SET D=1
- SET DICO("PT")=+Y
- +1 DO X(+Y,.01)
- QUIT
- +2 ;
- X(Y,D) ;Remember that we have used this field
- SET DICN=Y
- +1 IF $DATA(DICOMPX)#2
- SET DICOMPX=Y_U_D_$EXTRACT(";",1,$LENGTH(DICOMPX))_DICOMPX
- +2 QUIT
- +3 ;
- YN(SHOW) NEW X
- +1 SET X=$PIECE(^DIC(Y,0),U)
- +2 SET %=1
- IF DICOMP["?"
- Begin DoDot:1
- YOU ;**CCO/NI (+ next 2 lines) 'BY SO&SO, DO YOU MEAN THE SUCH&SUCH FILE, POINTING...?'
- NEW N
- +1 SET N(1)=DICN
- SET N(2)=X
- SET N(3)=$PIECE(^DD(DICODD,D,0),U)
- SET DICV=$PIECE(^(0),U,2)
- +2 WRITE !,$$EZBLD^DIALOG(8202,.N)
- +3 IF SHOW]""
- WRITE !," (""",$PIECE(J,U,2),""" ",SHOW,")"
- +4 DO YN^DICN
- End DoDot:1
- +5 IF %=1
- FOR M=M:1:$LENGTH(I)+1
- if $FIND(X,$EXTRACT(I,1,M))-1-M
- QUIT
- SET W=$EXTRACT(I,M+1)
- +6 QUIT