- DICOMP0 ;SFISC/GFT - EVALUATE COMPUTED FLD EXPR ;20JAN2016
- ;;22.2;VA FileMan;**2,14**;Jan 05, 2016;Build 8
- ;;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.
- ;
- ;X IS INPUT
- N DICOMPI
- SETFUNC I DPS,$D(DPS(DPS,"SET")),'$D(W(DPS)) S T="""",D=$P(X,T)_$P(X,T,2) G BAD:$L(D)+2\5-1!(D'?.UN)!(D?1"D".E)!(DUZ(0)'="@") S X=T_D_T,DICOMPX(D)=D,Y=0 Q
- LIT I X?1"""".E1"""" S Y=0,%=$E(X,2,$L(X)-1) K:%[""" X "!(%[""" D @") Y S X=""""_$$CONVQQ^DILIBF(%)_"""" Q
- L S T=DLV,DICN=X
- TRY G M:'$D(J(T))!'$D(I(T)),M:+J(T)'=J(T),M:$G(^DD(J(T),.01,0))="",UP:$P(^(0),U,2)["W" S DIC="^DD("_J(T)_",",DG=$O(^DD(J(T),0,"NM",0))_" "
- S DIC("S")=$S(W="["!($E(I,M,M+1)="'[")!$D(DICMX):"I ",1:"S %=$P(^(0),U,2) I '%,%'[""m"",")_"$$SCREEN^DICOMP0"
- D DICS^DICOMPY:DUZ(0)'="@"
- R I X?1"#"1.NP S X=$E(X,2,99) D ^DIC G:Y>0 A:DLV,X S X="#"_X ;HERE IS WHERE WE PROCESS THE NUMBER OR NAME OF A FIELD
- D ^DIC G A:Y>0
- N I $P(X,DG)="",X=DICN S X=$P(X,DG,2,9) G R
- NUMBER I X=$$EZBLD^DIALOG(7099) S Y=.001,Y(0)=0 G D ;THE WORD 'NUMBER' IN A COMPUTED EXPRESSION
- UP S T=T-1,X=DICN G M:T<0,TRY:$D(J(T)) F T=T-99:1 G TRY:'$D(J(T+1))
- ;
- A F D=M:1:$L(I)+1 Q:$F(X,$E(I,1,D))-1-D S W=$E(I,D+1)
- I DICOMP["?",DICN'="#.01",$P(Y,U,2)'=DICN,DG_$P(Y,U,2)'=DICN D G BAD:%<0,N:%-1
- .N N S N(1)=DICN,N(2)=DG,N(3)=$P(Y,U,2) W !,$$EZBLD^DIALOG(8201,.N) S %=1 D YN^DICN ;**CCO/NI (SAME)
- E S DICO("BACK",T)=+Y
- S M=D
- X I $D(DICOMPX)#2 S %Y=J(T)_U_+Y_$E(";",1,$L(DICOMPX)) S:";"_DICOMPX_";"'[(";"_%Y) DICOMPX=%Y_DICOMPX
- ;Take internal value of V-P Field for VPFILE Function --forgot about it when we realized that FILE Function exits!
- D S D=$P(Y(0),"^",2),%=T\100*100,DICN=+Y,DICOMPI=W=")" I D["V"&DICOMPI&$D(DPS($$NEST^DICOMP,"VPFILE")) S DICO("PT")=1
- E S DICOMPI=DICOMPI&$D(DPS($$NEST^DICOMP,"INTERNAL"))
- D DATE:D["D"&'DICOMPI
- I D["m"!D D MUL^DICOMPZ(D) Q
- I $D(DICOMPX(1,J(T),+Y)) S X=DICOMPX(1,J(T),+Y) G O
- I D["C" S:'$D(DG(%,T,+Y)) DG(%)=DG(%)+1,DG(%,T,+Y)=DG(%) S X=DQI_DG(%,T,+Y)_")" Q:D'["p"!DICOMPI S DICN=+$P(D,"p",2),%Y=$G(^DIC(DICN,0,"GL")) Q:%Y="" G POINT
- GET I DICOMP["G",T#100=0 S X="$$GET^DDSVAL("_J(T)_",D0,"_+Y_",,"""_$E("E",'DICOMPI)_""")" G O
- D G^DICOMPY ;This will set return value X equal to something like "$P(Y(2),U,3)"
- O Q:DICOMPI
- S T=J(T)
- S ;
- S %=DLV0,DG=W=":"&'$D(DPS(DPS,"$S"))
- V I D["V",DG N DICOMPV D I $D(DICOMPV) Q ;p14
- .N FILE,Y,FS S FILE=$P($E(I,M,999),":",2) Q:FILE=""
- .S FS=$O(^DD(T,DICN,"V","M",FILE,0)) Q:'FS
- .S Y=+^DD(T,DICN,"V",FS,0) Q:'Y
- .S FILE=$P($G(^DIC(Y,0,"GL")),"^",2) Q:FILE=""
- .S DICOMPV=" S D0="_X_",D0=$S($P(D0,"";"",2)="""_FILE_""":+D0,1:-1)" I $D(DICOMPX(0)) S DICOMPV=DICOMPV_","_DICOMPX(0)_"0)=D0"
- .D Y^DICOMPX ;S (DLV,DLV0)=DLV0+100,I(DLV0)=U_FILE,J(DLV0)=FN
- .D I^DICOMP
- .S X=DICOMPV
- .I W'=":" S I="#.01"_$E(I,M,999),M=0 Q ;IF WE HAVE NO TARGET FIELD IN THE NAVIGATED-TO FILE, USE .01
- .S M=M+1,W="",DG(DLV0)=1
- ;
- OUT I D["t"!(D["O"&(D'["P"!'DG))!(D["V"&'$D(DPS(DPS,"FILE"))) D Q ;OUTPUT TRANSFORM ON FIELD
- .K DATE(K+1) S X="$$EXTERNAL^DIDU("_T_","_DICN_","""","_X_")",DICO("DIERR")=1 ;$$EXTERNAL may set an error condition, so stifle DIERR
- SET I D["S" S DG(%)=DG(%)+1,DG(%,DG(%))="$C(59)_$P($G(^DD("_T_","_DICN_",0)),U,3)",X="$P($P("_DQI_DG(%)_"),$C(59)_"_X_"_"":"",2),$C(59))" ;S X="$$SET^DIQ("_T_","_DICN_","_X_")"
- Q:D'["P" S %Y=U_$P(Y(0),U,3),DICN=+$P(@(%Y_"0)"),U,2)
- POINT I W=":" G MR:'$$OKFILE^DICOMPX(DICN,DICOMP)
- I W'=":" S D=$P($G(^DD(DICN,.01,0)),U,2) I D'["V",D'["S",D'["P" D DATE:D["D" S X="$P($G("_%Y_"+"_X_",0)),U)" Q
- P G P^DICOMPX
- ;
- M S T=$F(X," IN ") I T S X=$E(X,1,T-5),W=":",M=T-4,I=X_W_$E(I,T,999),T=$F(I," FILE",M) S:T&$F(DPUNC,$E(I,T)) I=$E(I,1,T-6)_$E(I,T,999) G DICOMP0
- G MR:$L(X)>30 S DICF=X,T=$O(^DD("FUNC","B",X,0))
- G LITDATE:'$D(^DD("FUNC",+T,3)),LITDATE:^(3)
- I $G(^(1))'="" D 2^DICOMP S Y(0)=0,K=K+1,K(K)=X D DATE:$G(^(2))?1"D".E,DPS^DICOMPW Q
- G MR:X'?1"PRIOR"4.U S Y=X,X="$P($$LAST^DIAUTL("_J(DLV0)_",D0,""*""),U)" I Y["USER",$D(^VA(200)) S $E(X,$L(X))=",2)",DICN=200,%Y="^VA(200," G POINT
- G DATE
- ;
- LITDATE S %DT="T" I $L(X)>2 D ^%DT I Y>0 S X=Y,Y(0)=0 D DATE Q ;may be a literal date like "30DEC1944"
- BACKPNT S T=$O(^DIC("B",X)) I T]"",$P(T,X)=""!$D(^(X)),$D(J(0)) S T=DLV0 D ^DICOMPV I D>0 Q ;try backwards-pointer TOOK OFF CHECK FOR DICOMPW VARIABLE 3/28/2000
- MR I M'>$L(I),+X'=X D MR^DICOMP G L:X]""
- DDD I DICOMP["?",$D(^DDD("C")),DICOMP'["d" ; S T=$$^DICOMPU(X,.J,DICOMP,.DICMX) G BAD:$D(DUOUT) I T]"" W " (",T,")" D I $D(X),$D(Y) S:Y["m" DIMW="m" D:Y["D" DATE S K=K+1,K(K)=X_" S X=X" D DPS^DICOMPW S DLV=+Y Q
- ;.D ST^DICOMPX S D=$E(I,M,999),DICOMP=$TR(DICOMP,"?")_"d" D RCR^DICOMPZ(T) S M=0,I=D
- BAD K Y Q
- ;
- DATE ;
- S DATE(K+1)=1 Q
- ;
- SCREEN() ;Screen out certain fields as we process an atom
- I $D(DICO("BACK"))=11,$G(DICO("BACK",T))=Y Q 0
- I Y=DA,DICO(1)=T Q 0 ;Computed field cannot refer to itself!
- I $P(^(0),U,2) Q '$G(DBOOL) ;A multiple cannot be manipulated as a Boolean!
- I $P(^(0),U,2)'["P" Q 1
- N P S P=$P(^(0),U,3) I P]"",$D(@(U_P_"0)")) Q 1 ;Only allow a pointer that points to an existing file!
- Q 0
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICOMP0 5279 printed Jan 18, 2025@03:47:24 Page 2
- DICOMP0 ;SFISC/GFT - EVALUATE COMPUTED FLD EXPR ;20JAN2016
- +1 ;;22.2;VA FileMan;**2,14**;Jan 05, 2016;Build 8
- +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 ;X IS INPUT
- +8 NEW DICOMPI
- SETFUNC IF DPS
- IF $DATA(DPS(DPS,"SET"))
- IF '$DATA(W(DPS))
- SET T=""""
- SET D=$PIECE(X,T)_$PIECE(X,T,2)
- if $LENGTH(D)+2\5-1!(D'?.UN)!(D?1"D".E)!(DUZ(0)'="@")
- GOTO BAD
- SET X=T_D_T
- SET DICOMPX(D)=D
- SET Y=0
- QUIT
- LIT IF X?1"""".E1""""
- SET Y=0
- SET %=$EXTRACT(X,2,$LENGTH(X)-1)
- if %[""" X "!(%[""" D @")
- KILL Y
- SET X=""""_$$CONVQQ^DILIBF(%)_""""
- QUIT
- L SET T=DLV
- SET DICN=X
- TRY if '$DATA(J(T))!'$DATA(I(T))
- GOTO M
- if +J(T)'=J(T)
- GOTO M
- if $GET(^DD(J(T),.01,0))=""
- GOTO M
- if $PIECE(^(0),U,2)["W"
- GOTO UP
- SET DIC="^DD("_J(T)_","
- SET DG=$ORDER(^DD(J(T),0,"NM",0))_" "
- +1 SET DIC("S")=$SELECT(W="["!($EXTRACT(I,M,M+1)="'[")!$DATA(DICMX):"I ",1:"S %=$P(^(0),U,2) I '%,%'[""m"",")_"$$SCREEN^DICOMP0"
- +2 if DUZ(0)'="@"
- DO DICS^DICOMPY
- R ;HERE IS WHERE WE PROCESS THE NUMBER OR NAME OF A FIELD
- IF X?1"#"1.NP
- SET X=$EXTRACT(X,2,99)
- DO ^DIC
- if Y>0
- if DLV
- GOTO A
- GOTO X
- SET X="#"_X
- +1 DO ^DIC
- if Y>0
- GOTO A
- N IF $PIECE(X,DG)=""
- IF X=DICN
- SET X=$PIECE(X,DG,2,9)
- GOTO R
- NUMBER ;THE WORD 'NUMBER' IN A COMPUTED EXPRESSION
- IF X=$$EZBLD^DIALOG(7099)
- SET Y=.001
- SET Y(0)=0
- GOTO D
- UP SET T=T-1
- SET X=DICN
- if T<0
- GOTO M
- if $DATA(J(T))
- GOTO TRY
- FOR T=T-99:1
- if '$DATA(J(T+1))
- GOTO TRY
- +1 ;
- A FOR D=M:1:$LENGTH(I)+1
- if $FIND(X,$EXTRACT(I,1,D))-1-D
- QUIT
- SET W=$EXTRACT(I,D+1)
- +1 IF DICOMP["?"
- IF DICN'="#.01"
- IF $PIECE(Y,U,2)'=DICN
- IF DG_$PIECE(Y,U,2)'=DICN
- Begin DoDot:1
- +2 ;**CCO/NI (SAME)
- NEW N
- SET N(1)=DICN
- SET N(2)=DG
- SET N(3)=$PIECE(Y,U,2)
- WRITE !,$$EZBLD^DIALOG(8201,.N)
- SET %=1
- DO YN^DICN
- End DoDot:1
- if %<0
- GOTO BAD
- if %-1
- GOTO N
- +3 IF '$TEST
- SET DICO("BACK",T)=+Y
- +4 SET M=D
- X IF $DATA(DICOMPX)#2
- SET %Y=J(T)_U_+Y_$EXTRACT(";",1,$LENGTH(DICOMPX))
- if ";"_DICOMPX_";"'[(";"_%Y)
- SET DICOMPX=%Y_DICOMPX
- +1 ;Take internal value of V-P Field for VPFILE Function --forgot about it when we realized that FILE Function exits!
- D SET D=$PIECE(Y(0),"^",2)
- SET %=T\100*100
- SET DICN=+Y
- SET DICOMPI=W=")"
- IF D["V"&DICOMPI&$DATA(DPS($$NEST^DICOMP,"VPFILE"))
- SET DICO("PT")=1
- +1 IF '$TEST
- SET DICOMPI=DICOMPI&$DATA(DPS($$NEST^DICOMP,"INTERNAL"))
- +2 if D["D"&'DICOMPI
- DO DATE
- +3 IF D["m"!D
- DO MUL^DICOMPZ(D)
- QUIT
- +4 IF $DATA(DICOMPX(1,J(T),+Y))
- SET X=DICOMPX(1,J(T),+Y)
- GOTO O
- +5 IF D["C"
- if '$DATA(DG(%,T,+Y))
- SET DG(%)=DG(%)+1
- SET DG(%,T,+Y)=DG(%)
- SET X=DQI_DG(%,T,+Y)_")"
- if D'["p"!DICOMPI
- QUIT
- SET DICN=+$PIECE(D,"p",2)
- SET %Y=$GET(^DIC(DICN,0,"GL"))
- if %Y=""
- QUIT
- GOTO POINT
- GET IF DICOMP["G"
- IF T#100=0
- SET X="$$GET^DDSVAL("_J(T)_",D0,"_+Y_",,"""_$EXTRACT("E",'DICOMPI)_""")"
- GOTO O
- +1 ;This will set return value X equal to something like "$P(Y(2),U,3)"
- DO G^DICOMPY
- O if DICOMPI
- QUIT
- +1 SET T=J(T)
- S ;
- +1 SET %=DLV0
- SET DG=W=":"&'$DATA(DPS(DPS,"$S"))
- V ;p14
- IF D["V"
- IF DG
- NEW DICOMPV
- Begin DoDot:1
- +1 NEW FILE,Y,FS
- SET FILE=$PIECE($EXTRACT(I,M,999),":",2)
- if FILE=""
- QUIT
- +2 SET FS=$ORDER(^DD(T,DICN,"V","M",FILE,0))
- if 'FS
- QUIT
- +3 SET Y=+^DD(T,DICN,"V",FS,0)
- if 'Y
- QUIT
- +4 SET FILE=$PIECE($GET(^DIC(Y,0,"GL")),"^",2)
- if FILE=""
- QUIT
- +5 SET DICOMPV=" S D0="_X_",D0=$S($P(D0,"";"",2)="""_FILE_""":+D0,1:-1)"
- IF $DATA(DICOMPX(0))
- SET DICOMPV=DICOMPV_","_DICOMPX(0)_"0)=D0"
- +6 ;S (DLV,DLV0)=DLV0+100,I(DLV0)=U_FILE,J(DLV0)=FN
- DO Y^DICOMPX
- +7 DO I^DICOMP
- +8 SET X=DICOMPV
- +9 ;IF WE HAVE NO TARGET FIELD IN THE NAVIGATED-TO FILE, USE .01
- IF W'=":"
- SET I="#.01"_$EXTRACT(I,M,999)
- SET M=0
- QUIT
- +10 SET M=M+1
- SET W=""
- SET DG(DLV0)=1
- End DoDot:1
- IF $DATA(DICOMPV)
- QUIT
- +11 ;
- OUT ;OUTPUT TRANSFORM ON FIELD
- IF D["t"!(D["O"&(D'["P"!'DG))!(D["V"&'$DATA(DPS(DPS,"FILE")))
- Begin DoDot:1
- +1 ;$$EXTERNAL may set an error condition, so stifle DIERR
- KILL DATE(K+1)
- SET X="$$EXTERNAL^DIDU("_T_","_DICN_","""","_X_")"
- SET DICO("DIERR")=1
- End DoDot:1
- QUIT
- SET ;S X="$$SET^DIQ("_T_","_DICN_","_X_")"
- IF D["S"
- SET DG(%)=DG(%)+1
- SET DG(%,DG(%))="$C(59)_$P($G(^DD("_T_","_DICN_",0)),U,3)"
- SET X="$P($P("_DQI_DG(%)_"),$C(59)_"_X_"_"":"",2),$C(59))"
- +1 if D'["P"
- QUIT
- SET %Y=U_$PIECE(Y(0),U,3)
- SET DICN=+$PIECE(@(%Y_"0)"),U,2)
- POINT IF W=":"
- if '$$OKFILE^DICOMPX(DICN,DICOMP)
- GOTO MR
- +1 IF W'=":"
- SET D=$PIECE($GET(^DD(DICN,.01,0)),U,2)
- IF D'["V"
- IF D'["S"
- IF D'["P"
- if D["D"
- DO DATE
- SET X="$P($G("_%Y_"+"_X_",0)),U)"
- QUIT
- P GOTO P^DICOMPX
- +1 ;
- M SET T=$FIND(X," IN ")
- IF T
- SET X=$EXTRACT(X,1,T-5)
- SET W=":"
- SET M=T-4
- SET I=X_W_$EXTRACT(I,T,999)
- SET T=$FIND(I," FILE",M)
- if T&$FIND(DPUNC,$EXTRACT(I,T))
- SET I=$EXTRACT(I,1,T-6)_$EXTRACT(I,T,999)
- GOTO DICOMP0
- +1 if $LENGTH(X)>30
- GOTO MR
- SET DICF=X
- SET T=$ORDER(^DD("FUNC","B",X,0))
- +2 if '$DATA(^DD("FUNC",+T,3))
- GOTO LITDATE
- if ^(3)
- GOTO LITDATE
- +3 IF $GET(^(1))'=""
- DO 2^DICOMP
- SET Y(0)=0
- SET K=K+1
- SET K(K)=X
- if $GET(^(2))?1"D".E
- DO DATE
- DO DPS^DICOMPW
- QUIT
- +4 if X'?1"PRIOR"4.U
- GOTO MR
- SET Y=X
- SET X="$P($$LAST^DIAUTL("_J(DLV0)_",D0,""*""),U)"
- IF Y["USER"
- IF $DATA(^VA(200))
- SET $EXTRACT(X,$LENGTH(X))=",2)"
- SET DICN=200
- SET %Y="^VA(200,"
- GOTO POINT
- +5 GOTO DATE
- +6 ;
- LITDATE ;may be a literal date like "30DEC1944"
- SET %DT="T"
- IF $LENGTH(X)>2
- DO ^%DT
- IF Y>0
- SET X=Y
- SET Y(0)=0
- DO DATE
- QUIT
- BACKPNT ;try backwards-pointer TOOK OFF CHECK FOR DICOMPW VARIABLE 3/28/2000
- SET T=$ORDER(^DIC("B",X))
- IF T]""
- IF $PIECE(T,X)=""!$DATA(^(X))
- IF $DATA(J(0))
- SET T=DLV0
- DO ^DICOMPV
- IF D>0
- QUIT
- MR IF M'>$LENGTH(I)
- IF +X'=X
- DO MR^DICOMP
- if X]""
- GOTO L
- DDD ; S T=$$^DICOMPU(X,.J,DICOMP,.DICMX) G BAD:$D(DUOUT) I T]"" W " (",T,")" D I $D(X),$D(Y) S:Y["m" DIMW="m" D:Y["D" DATE S K=K+1,K(K)=X_" S X=X" D DPS^DICOMPW S DLV=+Y Q
- IF DICOMP["?"
- IF $DATA(^DDD("C"))
- IF DICOMP'["d"
- +1 ;.D ST^DICOMPX S D=$E(I,M,999),DICOMP=$TR(DICOMP,"?")_"d" D RCR^DICOMPZ(T) S M=0,I=D
- BAD KILL Y
- QUIT
- +1 ;
- DATE ;
- +1 SET DATE(K+1)=1
- QUIT
- +2 ;
- SCREEN() ;Screen out certain fields as we process an atom
- +1 IF $DATA(DICO("BACK"))=11
- IF $GET(DICO("BACK",T))=Y
- QUIT 0
- +2 ;Computed field cannot refer to itself!
- IF Y=DA
- IF DICO(1)=T
- QUIT 0
- +3 ;A multiple cannot be manipulated as a Boolean!
- IF $PIECE(^(0),U,2)
- QUIT '$GET(DBOOL)
- +4 IF $PIECE(^(0),U,2)'["P"
- QUIT 1
- +5 ;Only allow a pointer that points to an existing file!
- NEW P
- SET P=$PIECE(^(0),U,3)
- IF P]""
- IF $DATA(@(U_P_"0)"))
- QUIT 1
- +6 QUIT 0