DIQ1 ;SFISC/XAK-INQUIRY WITH COMPUTED FIELDS ;26JAN2004
;;22.2;VA FileMan;**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.
;
A N DIDQ,DICMX,DIQ1W,D,Z,DIQX
S DIDQ=DD,DICMX="D LF^DIQ K:'S D I S W O,"": "",X S X="""",O=$J(X,$L(O))"
N DD
F DIQ1W=0:0 S DIQ1W=$O(^DD(DIDQ,DIQ1W)) Q:DIQ1W'>0 I $D(^(DIQ1W,0))#2 S Z=^(0),C=$P(Z,U,2) I C["C" S X="",O=$$LABEL^DIALOGZ(DIDQ,DIQ1W)_" (c)" X $P(Z,U,5,99) D:X]""&(C'["m") Q:'S ;**CCO/NI LOOP THRU ALL FIELDS TO FIND COMPUTED
.N Y,W S Y=X,W=DIQ1W
.I C["p",Y S Y=$$CP(C,Y)
.E I C["D" X ^DD("DD")
.D W2^DIQ
Q
;
CP(C,X) ;
S:C["p" C=+$P(C,"p",2) I C,$D(^DIC(C,0,"GL")),$D(@(^("GL")_"0)")),$D(^(X,0)) S X=$$EXTERNAL^DIDU(C,.01,"",$P(^(0),U))
Q X
;
EN ;
N C,DI ;p14
Q:'$D(DIC)!($D(DA)[0)!($D(DR)[0) S DIL=0,(DA(0),D0)=DA,DIQ0=""
I $D(DIQ)#2 G Q:DIQ["^"!($E(DIQ,1,2)="DI") S:DIQ'["(" DIQ=DIQ_"("
S:'$D(DIQ(0)) DIQ(0)="",DIQ0="DIQ(0),"
I $D(DIQ)[0 S DIQ="^UTILITY(""DIQ1"",$J,",DIQ0="DIQ,"
S DIQ0=DIQ0_"DIQ0"
I DIC S DIC=$S($D(^DIC(DIC,0,"GL")):^("GL"),1:"") G:DIC="" Q
L G Q:'$D(@(DIC_"0)")) S DI=+$P(^(0),U,2) G Q:'$D(^(DA,0))
N DII F DII=1:1 S DIQ1=$P(DR,";",DII) Q:DIQ1="" D C:DIQ1[":",F:DIQ1>0
Q Q:DIL K %,I,J,X,Y,C,DA(0),DRS,DIL,DI,DIQ1 K:DIQ0]"" @DIQ0 K:$D(DIQ0) DIQ0
Q
;
C S DIQ2=$P(DIQ1,":",2)
F DIQ1=DIQ1:0 D F S DIQ1=$O(^DD(DI,DIQ1)) I DIQ1'>0!(DIQ1'<DIQ2) S:DIQ1'=DIQ2 DIQ1=0 Q
Q
F Q:'$D(^DD(DI,DIQ1,0))
S Y=^(0),C=$P(Y,U,4),X=$P(C,";",2),C=$P(C,";"),J=$P(Y,U,2) G P:J["C"
I +C'=C S C=""""_C_""""
I X=0,$D(^DD(+J,.01,0)) G WD:$P(^(0),U,2)["W",S
S C=$G(@(DIC_DA_","_C_")")),Y=$S(X["E":$E(C,+$P(X,"E",2),+$P(X,",",2)),1:$P(C,U,X))
I DIQ(0)["I",(DIQ(0)["N"&(Y]"")!(DIQ(0)'["N")) S @(DIQ_"DI,DA,DIQ1,""I"")")=Y
P Q:DIQ(0)'["E"&(DIQ(0)["I")
I J["C" X $P(Y,U,5,999) K Y S Y=X D:J["D" D^DIQ
I J'["C" S C=$P(^DD(DI,DIQ1,0),U,2) D:Y]"" Y^DIQ
Q:Y=""&(DIQ(0)["N")
S @(DIQ_"DI,DA,DIQ1"_$S(DIQ(0)'["E":"",1:",""E""")_")")=Y
Q
WD F X=0:0 S X=$O(@(DIC_"DA,"_C_",X)")) Q:X'>0 S @(DIQ_"DI,DA,DIQ1,X)")=^(X,0)
Q
S ;
Q:'$D(DR(+J)) Q:'$D(DA(+J)) N DIQ1,I,DI S DIL=DIL+1
S DRS(DIL)=DR,DIC(DIL)=DIC,DR=DR(+J),DA(DIL)=DA
S DI=+J,DIC=DIC_DA_","_C_",",DA=DA(+J),@("D"_DIL)=DA
D L S DR=DRS(DIL),DA=DA(DIL),DIC=DIC(DIL)
K DRS(DIL),DIC(DIL),DA(DIL),@("D"_DIL)
S DIL=DIL-1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIQ1 2535 printed Nov 22, 2024@18:03:30 Page 2
DIQ1 ;SFISC/XAK-INQUIRY WITH COMPUTED FIELDS ;26JAN2004
+1 ;;22.2;VA FileMan;**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 ;
A NEW DIDQ,DICMX,DIQ1W,D,Z,DIQX
+1 SET DIDQ=DD
SET DICMX="D LF^DIQ K:'S D I S W O,"": "",X S X="""",O=$J(X,$L(O))"
+2 NEW DD
+3 ;**CCO/NI LOOP THRU ALL FIELDS TO FIND COMPUTED
FOR DIQ1W=0:0
SET DIQ1W=$ORDER(^DD(DIDQ,DIQ1W))
if DIQ1W'>0
QUIT
IF $DATA(^(DIQ1W,0))#2
SET Z=^(0)
SET C=$PIECE(Z,U,2)
IF C["C"
SET X=""
SET O=$$LABEL^DIALOGZ(DIDQ,DIQ1W)_" (c)"
XECUTE $PIECE(Z,U,5,99)
if X]""&(C'["m")
Begin DoDot:1
+4 NEW Y,W
SET Y=X
SET W=DIQ1W
+5 IF C["p"
IF Y
SET Y=$$CP(C,Y)
+6 IF '$TEST
IF C["D"
XECUTE ^DD("DD")
+7 DO W2^DIQ
End DoDot:1
if 'S
QUIT
+8 QUIT
+9 ;
CP(C,X) ;
+1 if C["p"
SET C=+$PIECE(C,"p",2)
IF C
IF $DATA(^DIC(C,0,"GL"))
IF $DATA(@(^("GL")_"0)"))
IF $DATA(^(X,0))
SET X=$$EXTERNAL^DIDU(C,.01,"",$PIECE(^(0),U))
+2 QUIT X
+3 ;
EN ;
+1 ;p14
NEW C,DI
+2 if '$DATA(DIC)!($DATA(DA)[0)!($DATA(DR)[0)
QUIT
SET DIL=0
SET (DA(0),D0)=DA
SET DIQ0=""
+3 IF $DATA(DIQ)#2
if DIQ["^"!($EXTRACT(DIQ,1,2)="DI")
GOTO Q
if DIQ'["("
SET DIQ=DIQ_"("
+4 if '$DATA(DIQ(0))
SET DIQ(0)=""
SET DIQ0="DIQ(0),"
+5 IF $DATA(DIQ)[0
SET DIQ="^UTILITY(""DIQ1"",$J,"
SET DIQ0="DIQ,"
+6 SET DIQ0=DIQ0_"DIQ0"
+7 IF DIC
SET DIC=$SELECT($DATA(^DIC(DIC,0,"GL")):^("GL"),1:"")
if DIC=""
GOTO Q
L if '$DATA(@(DIC_"0)"))
GOTO Q
SET DI=+$PIECE(^(0),U,2)
if '$DATA(^(DA,0))
GOTO Q
+1 NEW DII
FOR DII=1:1
SET DIQ1=$PIECE(DR,";",DII)
if DIQ1=""
QUIT
if DIQ1[":"
DO C
if DIQ1>0
DO F
Q if DIL
QUIT
KILL %,I,J,X,Y,C,DA(0),DRS,DIL,DI,DIQ1
if DIQ0]""
KILL @DIQ0
if $DATA(DIQ0)
KILL DIQ0
+1 QUIT
+2 ;
C SET DIQ2=$PIECE(DIQ1,":",2)
+1 FOR DIQ1=DIQ1:0
DO F
SET DIQ1=$ORDER(^DD(DI,DIQ1))
IF DIQ1'>0!(DIQ1'<DIQ2)
if DIQ1'=DIQ2
SET DIQ1=0
QUIT
+2 QUIT
F if '$DATA(^DD(DI,DIQ1,0))
QUIT
+1 SET Y=^(0)
SET C=$PIECE(Y,U,4)
SET X=$PIECE(C,";",2)
SET C=$PIECE(C,";")
SET J=$PIECE(Y,U,2)
if J["C"
GOTO P
+2 IF +C'=C
SET C=""""_C_""""
+3 IF X=0
IF $DATA(^DD(+J,.01,0))
if $PIECE(^(0),U,2)["W"
GOTO WD
GOTO S
+4 SET C=$GET(@(DIC_DA_","_C_")"))
SET Y=$SELECT(X["E":$EXTRACT(C,+$PIECE(X,"E",2),+$PIECE(X,",",2)),1:$PIECE(C,U,X))
+5 IF DIQ(0)["I"
IF (DIQ(0)["N"&(Y]"")!(DIQ(0)'["N"))
SET @(DIQ_"DI,DA,DIQ1,""I"")")=Y
P if DIQ(0)'["E"&(DIQ(0)["I")
QUIT
+1 IF J["C"
XECUTE $PIECE(Y,U,5,999)
KILL Y
SET Y=X
if J["D"
DO D^DIQ
+2 IF J'["C"
SET C=$PIECE(^DD(DI,DIQ1,0),U,2)
if Y]""
DO Y^DIQ
+3 if Y=""&(DIQ(0)["N")
QUIT
+4 SET @(DIQ_"DI,DA,DIQ1"_$SELECT(DIQ(0)'["E":"",1:",""E""")_")")=Y
+5 QUIT
WD FOR X=0:0
SET X=$ORDER(@(DIC_"DA,"_C_",X)"))
if X'>0
QUIT
SET @(DIQ_"DI,DA,DIQ1,X)")=^(X,0)
+1 QUIT
S ;
+1 if '$DATA(DR(+J))
QUIT
if '$DATA(DA(+J))
QUIT
NEW DIQ1,I,DI
SET DIL=DIL+1
+2 SET DRS(DIL)=DR
SET DIC(DIL)=DIC
SET DR=DR(+J)
SET DA(DIL)=DA
+3 SET DI=+J
SET DIC=DIC_DA_","_C_","
SET DA=DA(+J)
SET @("D"_DIL)=DA
+4 DO L
SET DR=DRS(DIL)
SET DA=DA(DIL)
SET DIC=DIC(DIL)
+5 KILL DRS(DIL),DIC(DIL),DA(DIL),@("D"_DIL)
+6 SET DIL=DIL-1
QUIT
