Changeset 623 for WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP1.m

Timestamp:

Dec 4, 2009, 12:11:15 AM (14 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

File:

• WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP1.m (modified) (1 diff)

WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP1.m

@@ -1 @@
-DICOMP1 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;19JUNE2007
-        ;;22.0;VA FileMan;**6,44,76,152**;Mar 30, 1999;Build 10
-        ;Per VHA Directive 2004-038, this routine should not be modified.
-        F  Q:'$D(DPS(DPS,"ST"))  D DPS^DICOMPW S K=K+1,K(K)=X
-        G 0:DPS
-INIT    S T=99,DLV0=0,X="",K=1 D ST ;ST will build code to get top=level values
-NN      I $D(K(K,1)) S DLV0=K(K,1) K K(K,1) D ST ;'1' flags a change in levels
-        I $D(K(K,9)) F %=1:1:K K DATE(%)
-        G S:$D(K(K))[0,K1:K(K)=""
-        I " "[$E(K(K)) D
-        .Q:X=""
-        .I K(K)?1" S ".E D  Q
-AS      ..D EX I $L(K(K))+$L(X)>160 D M Q
-        ..S K(K)=$E(K(K),4,999),X=X_","
-        .D EX:W,M:$L(X)+$L(K(K))>180
-        E  I 'W D M:$L(X)+$L(K(K))>165 S X=X_" S X=",W=6
-        D:K(K)?1P
-P       .I "\/"[K(K),$G(K(K+1))'?.NP S K=K+1,K(K)=",X=$S("_K(K)_":X"_K(K-1)_K(K)_",1:""*******"")"
-        .I $L(X)>150,$F(DPUNC,K(K))>3 D M,SX
-        G A:'$D(DATE(K))
-DATE    I $G(K(K-1))="_",X?.E1"_" S X=$E(X,1,$L(X)-1) D EXTRASB S Y=$$DGI^DICOMP,X=X_" S "_Y_"=X,X="_K(K)_" S Y=X X ^DD(""DD"") S X="_Y_"_Y",K(K)="" G A
-        S Y=1 I $G(K(K-1))="+" S X=X_"0,X2=X,X1="_K(K) G DTC
-2       G A:$D(K(K+2))[0
-        K DATE(K)
-        I $D(DATE(K+2))[0,$F("+-",K(K+1))>1 S X=X_K(K)_",X1=X,X2="_K(K+1)_K(K+2),DATE(K+2)=1
-        E  G A:K(K+1)'="-" K DATE(K+2) S X=X_K(K)_",X1=X,X2="_K(K+2),Y=0
-        S K=K+2
-DTC     S K=K+1,X=X_",X="""" D"_$P(":X2 ^ C",U,Y+1)_"^%DTC:X1" G S:'$D(K(K)) D SX G NN:'Y S K=K-1,K(K)="" G 2
-        ;
-A       S W='$D(K(K,2)),X=X_K(K)
-K1      S K=K+1 G NN:$D(K(K))#2
-S       S I="" F  S I=$O(M(I)),W=0 Q:I=""  D M:$L(X)>235 S K=$O(M(I,"")),X=X_" S D"_I_"="_$S(DA:DQI_(K+80),1:"I("_K_",0")_")"
-        S I=-1 D SS S:X?.E1" S X=X" X=$E(X,1,$L(X)-6) I X'?1"S X="1N.NP!(DICOMP["Z") G Q
-0       ;NO GOT!  Come here when parsing fails
-        K X,DIM,DATE I DUZ(0)="@",DICOMP'["X" D
-        .Q:DICO'[" "
-        .S DIM=1 I $L(DICO," ")=2 F Y="OPEN","CLOSE","BREAK","USE" D  I '$D(DIM) Q
-        ..I $E(Y)=$P(DICO," ")!(Y=$P(DICO," ")) K DIM
-        .I $D(DIM) S X=DICO D ^DIM
-        S DICOMP="",DLV=DICO(1)
-Q       I DICOMP'["S" S K=DICO(1) F  S K=$O(I(K)) Q:K=""  K I(K),J(K)
-        I $D(X) S:$D(DICO("DIERR")) X="N DIERR "_X I $G(DICOMPQI) S X="N Y "_X
-Y       K Y I $D(DICO("RCR")) S Y=DICO("RCR")
-        E  S Y=DLV_$E("W",$D(DPS("W")))_$S($G(DBOOL)=1:"B",$D(DATE)>9:"D",1:"")_$E("X",$D(DIM))_$E("L",$D(DICO(2)))
-        S Y=Y_DIMW
-        I $D(DICO("PT")) S Y=Y_"p"_DICO("PT")
-        K K,DLV,DICOMP,DICMX Q
-        ;
-ST      S W=0,DG="" F  S DG=$O(DG(DLV0,DG)),Y=$P(DG,U,2) Q:DG=""  D
-        .I Y]"" S:+Y'=Y Y=""""_Y_"""" S I=DQI_DG(DLV0,DG)_")=$S($D(^(" D:T-DG!(DG<DLV0)  S I=I_Y_")):^("_Y_"),1:"""")" G VP
-        ..N T,QI,%
-X       ..S I=$P(I,U),%=DG\100*100
-        ..F T=0:1:DG#100 S QI=I(%) S I=I_QI_$E(",",1,T)_$S(DICOMP["T"&(DG<DICO(0)):"I("_%_",0)",1:"D"_T)_",",%=%+1
-        ..K DG(DLV0,DG)
-        ..;do not change above code to use "$G" until you change E2+4^DIP0 !
-C       .F  S %=$O(DG(DLV0,DG,0)) Q:'%  D  K DG(DLV0,DG,%) ;for Computed Fields
-        ..S I=" X ""N I,Y ""_$P(^DD("_J(DG)_","_%_",0),U,5,99)"
-        ..I DICOMP["T",DG<DICO(0) D
-        ...N W,SV S SV=X,X="N D0 S D0=I("_DG_",0)"_I D EXTRASB S I=X,X=SV
-        ..S I=I_" S "_DQI_DG(DLV0,DG,%)_")=X"
-        ..D EX:W,M:$L(X)+$L(I)>180 S X=X_I
-        .Q:$D(DG(DLV0,DG))[0
-        .S I=DG(DLV0,DG) I I?.N S I=$S(DA:DQI_(DLV0+I+80),1:"I("_(DLV0+I)_",0")_")=$G(D"_I_")"
-        .E  S I=DQI_+DG_")="_I
-        .K DG(DLV0,DG) G OV:DG?.N1A
-VP      .I $G(DICV)["V" S I=I_"_$C(59)_"""_$E(I(0),2,99)_""""
-OV      .I $L(I)+$L(X)>180 D M
-        .S:'W X=X_" S " S X=X_I_",",W=2
-        D EX S W=0 Q
-        ;
-M       D SS,EX
-EXTRASB D DIMP^DICOMPZ(X) S W=0 Q
-        ;
-SS      Q:$A(X)-32  S X=$E(X,2,999) G SS
-        ;
-EX      S X=$E(X,1,$L(X)-W+1) Q
-        ;
-SX      S X=X_" S X=X",W=1
-        Q
+DICOMP1 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;12:45 PM  9 Sep 2002
+ ;;22.0;VA FileMan;**6,44,76**;Mar 30, 1999
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
+ F  Q:'$D(DPS(DPS,"ST"))  D DPS^DICOMPW S K=K+1,K(K)=X
+ G 0:DPS
+INIT S T=99,DLV0=0,X="",K=1 D ST ;ST will build code to get top=level values
+NN I $D(K(K,1)) S DLV0=K(K,1) K K(K,1) D ST ;'1' flags a change in levels
+ I $D(K(K,9)) F %=1:1:K K DATE(%)
+ G S:$D(K(K))[0,K1:K(K)=""
+ I " "[$E(K(K)) D
+ .Q:X=""
+ .I K(K)?1" S ".E D  Q
+AS ..D EX I $L(K(K))+$L(X)>160 D M Q
+ ..S K(K)=$E(K(K),4,999),X=X_","
+ .D EX:W,M:$L(X)+$L(K(K))>180
+ E  I 'W D M:$L(X)+$L(K(K))>165 S X=X_" S X=",W=6
+ D:K(K)?1P
+P .I "\/"[K(K),$G(K(K+1))'?.NP S K=K+1,K(K)=",X=$S("_K(K)_":X"_K(K-1)_K(K)_",1:""*******"")"
+ .I $L(X)>150,$F(DPUNC,K(K))>3 D M,SX
+ G A:'$D(DATE(K))
+DATE I $G(K(K-1))="_",X?.E1"_" S X=$E(X,1,$L(X)-1) D EXTRASB S Y=$$DGI^DICOMP,X=X_" S "_Y_"=X,X="_K(K)_" S Y=X X ^DD(""DD"") S X="_Y_"_Y",K(K)="" G A
+ S Y=1 I $G(K(K-1))="+" S X=X_"0,X2=X,X1="_K(K) G DTC
+2 G A:$D(K(K+2))[0
+ K DATE(K)
+ I $D(DATE(K+2))[0,$F("+-",K(K+1))>1 S X=X_K(K)_",X1=X,X2="_K(K+1)_K(K+2),DATE(K+2)=1
+ E  G A:K(K+1)'="-" K DATE(K+2) S X=X_K(K)_",X1=X,X2="_K(K+2),Y=0
+ S K=K+2
+DTC S K=K+1,X=X_",X="""" D"_$P(":X2 ^ C",U,Y+1)_"^%DTC:X1" G S:'$D(K(K)) D SX G NN:'Y S K=K-1,K(K)="" G 2
+ ;
+A S W='$D(K(K,2)),X=X_K(K)
+K1 S K=K+1 G NN:$D(K(K))#2
+S S I="" F  S I=$O(M(I)),W=0 Q:I=""  D M:$L(X)>235 S K=$O(M(I,"")),X=X_" S D"_I_"="_$S(DA:DQI_(K+80),1:"I("_K_",0")_")"
+ S I=-1 D SS S:X?.E1" S X=X" X=$E(X,1,$L(X)-6) I X'?1"S X="1N.NP!(DICOMP["Z") G Q
+0 ;NO GOT!  Come here when parsing fails
+ K X,DIM,DATE I DUZ(0)="@",DICOMP'["X" D
+ .Q:DICO'[" "
+ .S DIM=1 I $L(DICO," ")=2 F Y="OPEN","CLOSE","BREAK","USE" D  I '$D(DIM) Q
+ ..I $E(Y)=$P(DICO," ")!(Y=$P(DICO," ")) K DIM
+ .I $D(DIM) S X=DICO D ^DIM
+ S DICOMP="",DLV=DICO(1)
+Q I DICOMP'["S" S K=DICO(1) F  S K=$O(I(K)) Q:K=""  K I(K),J(K)
+ I $G(DICOMPQI),$D(X) S X="N Y "_X
+Y K Y I $D(DICO("RCR")) S Y=DICO("RCR")
+ E  S Y=DLV_$E("W",$D(DPS("W")))_$S($G(DBOOL)=1:"B",$D(DATE)>9:"D",1:"")_$E("X",$D(DIM))_$E("L",$D(DICO(2)))
+ S Y=Y_DIMW
+ I $D(DICO("PT")) S Y=Y_"p"_DICO("PT")
+ K K,DLV,DICOMP,DICMX Q
+ ;
+ST S W=0,DG="" F  S DG=$O(DG(DLV0,DG)),Y=$P(DG,U,2) Q:DG=""  D
+ .I Y]"" S:+Y'=Y Y=""""_Y_"""" S I=DQI_DG(DLV0,DG)_")=$S($D(^(" D:T-DG!(DG<DLV0)  S I=I_Y_")):^("_Y_"),1:"""")" G VP
+ ..N T,QI,%
+X ..S I=$P(I,U),%=DG\100*100
+ ..F T=0:1:DG#100 S QI=I(%) S I=I_QI_$E(",",1,T)_$S(DICOMP["T"&(DG<DICO(0)):"I("_%_",0)",1:"D"_T)_",",%=%+1
+ ..K DG(DLV0,DG)
+ ..;do not change above code to use "$G" until you change E2+4^DIP0 !
+C .F  S %=$O(DG(DLV0,DG,0)) Q:'%  D  K DG(DLV0,DG,%) ;for Computed Fields
+ ..S I=" X ""N I,Y ""_$P(^DD("_J(DG)_","_%_",0),U,5,99)"
+ ..I DICOMP["T",DG<DICO(0) D
+ ...N W,SV S SV=X,X="N D0 S D0=I("_DG_",0)"_I D EXTRASB S I=X,X=SV
+ ..S I=I_" S "_DQI_DG(DLV0,DG,%)_")=X"
+ ..D EX:W,M:$L(X)+$L(I)>180 S X=X_I
+ .Q:$D(DG(DLV0,DG))[0
+ .S I=DG(DLV0,DG) I I?.N S I=$S(DA:DQI_(DLV0+I+80),1:"I("_(DLV0+I)_",0")_")=$G(D"_I_")"
+ .E  S I=DQI_+DG_")="_I
+ .K DG(DLV0,DG) G OV:DG?.N1A
+VP .I $G(DICV)["V" S I=I_"_$C(59)_"""_$E(I(0),2,99)_""""
+OV .I $L(I)+$L(X)>180 D M
+ .S:'W X=X_" S " S X=X_I_",",W=2
+ D EX S W=0 Q
+ ;
+M D SS,EX
+EXTRASB D DIMP^DICOMPZ(X) S W=0 Q
+ ;
+SS Q:$A(X)-32  S X=$E(X,2,999) G SS
+ ;
+EX S X=$E(X,1,$L(X)-W+1) Q
+ ;
+SX S X=X_" S X=X",W=1
+ Q