- DIQ1 ;SFISC/XAK-INQUIRY WITH COMPUTED FIELDS ;6:09 AM 24 Nov 2003
- ;;22.0;VA FileMan;**19,64,76,133**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- A S DIDQ=DD S:'$D(DICMX) DICMX="W !,O,"": "",X"
- N W,DD,D,Z
- F W=0:0 S W=$O(^DD(DIDQ,W)) Q:W'>0 I $D(^(W,0))#2 S Z=^(0),C=$P(Z,U,2),O=$P(Z,U)_" (c)" I C["C" X $P(Z,U,5,99) I X]"" D Q:'S
- .N Y S Y=X
- .I C["p",Y S Y=$$CP(C,Y)
- .E I C["D" X ^DD("DD")
- .D W2^DIQ
- K DIDQ,DICMX 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 ;
- 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
- DIQ1 ;SFISC/XAK-INQUIRY WITH COMPUTED FIELDS ;6:09 AM 24 Nov 2003
- +1 ;;22.0;VA FileMan;**19,64,76,133**;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- A SET DIDQ=DD
- IF '$DATA(DICMX)
- SET DICMX="W !,O,"": "",X"
- +1 NEW W,DD,D,Z
- +2 FOR W=0:0
- SET W=$ORDER(^DD(DIDQ,W))
- IF W'>0
- QUIT
- IF $DATA(^(W,0))#2
- SET Z=^(0)
- SET C=$PIECE(Z,U,2)
- SET O=$PIECE(Z,U)_" (c)"
- IF C["C"
- XECUTE $PIECE(Z,U,5,99)
- IF X]""
- Begin DoDot:1
- +3 NEW Y
- SET Y=X
- +4 IF C["p"
- IF Y
- SET Y=$$CP(C,Y)
- +5 IF '$TEST
- IF C["D"
- XECUTE ^DD("DD")
- +6 DO W2^DIQ
- End DoDot:1
- IF 'S
- QUIT
- +7 KILL DIDQ,DICMX
- QUIT
- +8 ;
- 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 IF '$DATA(DIC)!($DATA(DA)[0)!($DATA(DR)[0)
- QUIT
- SET DIL=0
- SET (DA(0),D0)=DA
- SET DIQ0=""
- +2 IF $DATA(DIQ)#2
- IF DIQ["^"!($EXTRACT(DIQ,1,2)="DI")
- GOTO Q
- IF DIQ'["("
- SET DIQ=DIQ_"("
- +3 IF '$DATA(DIQ(0))
- SET DIQ(0)=""
- SET DIQ0="DIQ(0),"
- +4 IF $DATA(DIQ)[0
- SET DIQ="^UTILITY(""DIQ1"",$J,"
- SET DIQ0="DIQ,"
- +5 SET DIQ0=DIQ0_"DIQ0"
- +6 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
