DICM3 ;SFISC/XAK,TKW-PROCESS INDIVIDUAL FILE FOR VAR PTR ;12/7/99 14:59 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**16,4,20**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
DIC ; Does recursive ^DIC call to single pointed-to file.
Q:$D(DIVP(+DIVPDIC))
I $D(DIV("V")) N % D X % I '$T K Y S Y=-1 D DQ Q
. S Y=DIVP,Y(0)=DIVPDIC
. S %=$S($G(DIV("V"))]"":DIV("V"),1:$G(DIV("V",1))) Q
I '$D(^DIC(+DIVPDIC,0,"GL")) S Y=-1 D DQ Q
S (Y,DIC)=^("GL"),%="DIC"_DICR
N:'$D(DIVPSEL) DIVPSEL S DIVPSEL(DICR)=0
S D=$G(DICR(DICR,4)) S:D="" D="B"
I DIC["""" S Y="" F A1=1:1:$L(DIC,",")-1 S A0=$P(DIC,",",A1) S:A0["""" A0=$P(A0,"""")_""""""_$P(A0,"""",2)_""""""_$P(A0,"""",3) S Y=Y_A0_","
;
; Build screen to select only pointed-to entries.
K DIC("S") N DICODE S DICODE=""
I DIC(0)'["L"!'$D(DICR(DICR,"V")) D
. N DIX S DIX=""""_D_"""" D
. . I $G(DINDEX("#"))>1 D BLDC^DICM0("("_DIVDIC,DIX,DINDEX("#"),DIFILEI,Y,.DICODE,.DICR) Q
. . S DICODE="X ""I 0"" N "_%_$S($D(DICR(DICR,"S")):",%Y"_DICR,1:"")_" "
. . S DICODE=DICODE_"F "_%_"=0:0 S "_%_"=$O("_DIVDIC_DIX_",(+Y_"";"_$E(Y,2,99)_"""),"_%_")) Q:"_%_"'>0 I $D("_DIVDIC_%_",0))"
. . I DIC(0)["T",DICR=1 S DICODE=DICODE_$$CHKTMP^DICM0(.DIC,DICR,DIFILEI,%)
. . I $D(DICR(DICR,"S")) S DICODE=DICODE_" S %Y"_DICR_"=Y,Y="_%_" X DICR("_DICR_",""S"") S Y=%Y"_DICR_" I "
. . S DICODE=DICODE_" Q" Q
. S:DICODE]"" DIC("S")=DICODE Q
;
; Set DIC(0)
S %=DIC(0),DIC(0)="D"_$E("M",%'["B") D
. N I F I="E","O","B","T","V" I %[I S DIC(0)=DIC(0)_I
. Q
I %["L",$D(DICR(DICR,"V")),$$OKTOADD^DICM0(DIVDO,.DINDEX,.DIFINDER) D
. I $P(DIVPDIC,U,6)="y" S DIC(0)=DIC(0)_"L"
. ; Execute screen code for screened pointer (should set DIC("S")).
. K D Q:$P(DIVPDIC,U,5)'="y"
. N DICODE S DICODE=$G(^DD(DIVDO,DIVY,"V",DIVP,1)) Q:DICODE=""
. N DICSSAV S DICSSAV=$G(DIC("S"))
. X DICODE
. S DIC("S")=$G(DIC("S"))_$S(DICSSAV]"":" "_DICSSAV,1:"")
. Q
E K D
; If user passed list of indexes to use on pointed-to file, setup.
S %=$G(DIC("PTRIX",DIFILEI,DINDEX(1,"FIELD"),+DIVPDIC))
I %]"" N DF,DID S D=% D SETIX^DICM0(.D,.DIC,.DID,.DF)
S:$G(D)="" D="B" N DISAVED S DISAVED=D
;
; Write prompt
I DIC(0)["E" D
. I $G(DICODE)="" D H1^DIE3 W:'$D(DDS) ! Q
. D H1 Q
;
; Set up rest of variables needed for DQ^DICQ or ^DIC call.
D DO^DIC1
N DS,DINDEX,DIFILEI
S D=DISAVED K DISAVED
; Handle ? help
I X?."?" D D DQ Q
. S DZ=X_$E("?",'$D(DICR(DICR,"V")))
. D DQ^DICQ S X=$S($D(DZ):DZ,1:"?"),Y=-1 Q
; Do ^DIC call.
D X^DIC I $D(DUOUT) D DQ Q
;
; Process output from ^DIC call.
S X=+Y_";"_$E(DIC,2,99),%=1 K:Y<0 X
I Y<0,DIC(0)["E",$D(DIVP1),$D(DICR(DICR,"V")) W !
I '$D(DICR(DICR,"V"))!(DICR>1) K DICR("^",+DIVPDIC) S DIVP(+DIVPDIC)=0
I Y>0,'DIVPSEL(DICR),DIC(0)["E",'$P(Y,U,3),$P(@(DIC_"0)"),U,2)'["O" D
. N I F I=(DICR-1):-1 Q:'$D(DIVPSEL(I)) S DIVPSEL(I)=1
. D S1^DIE3 I $G(%Y)?1"^^".E S (DIROUT,DUOUT)=1
. Q
DQ I $D(DIC("PTRIX")) M DIV("PTRIX")=DIC("PTRIX")
K A0,A1,DIC,DO S DIC=DIVDIC,D=$S($D(DICR(DICR,4)):DICR(DICR,4),1:"B")
S DIC(0)=DICR(DICR,0)
F %="V","PTRIX" I $D(DIV(%)) M DIC(%)=DIV(%)
Q
;
H1 W:'$D(DDS) !
N A1,DST,DIPAR S A1="T"
S DIPAR(1)=$P(DIVPDIC,U,2),DIPAR(2)=$P($G(^DD(DIVDO,DIVY,0)),U)
S DST=$$EZBLD^DIALOG(8097,.DIPAR)
D S^DIE3 W:'$D(DDS) ! Q
;
;8070 Searching for a |1|
;8097 Searching for a |1|, (pointed-to by |2|)
;
DICM3 ;SFISC/XAK,TKW-PROCESS INDIVIDUAL FILE FOR VAR PTR ;12/7/99 14:59 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**16,4,20**;Mar 30, 1999
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
DIC ; Does recursive ^DIC call to single pointed-to file.
+1 IF $DATA(DIVP(+DIVPDIC))
QUIT
+2 IF $DATA(DIV("V"))
NEW %
Begin DoDot:1
+3 SET Y=DIVP
SET Y(0)=DIVPDIC
+4 SET %=$SELECT($GET(DIV("V"))]"":DIV("V"),1:$GET(DIV("V",1)))
QUIT
End DoDot:1
XECUTE %
IF '$TEST
KILL Y
SET Y=-1
DO DQ
QUIT
+5 IF '$DATA(^DIC(+DIVPDIC,0,"GL"))
SET Y=-1
DO DQ
QUIT
+6 SET (Y,DIC)=^("GL")
SET %="DIC"_DICR
+7 IF '$DATA(DIVPSEL)
NEW DIVPSEL
SET DIVPSEL(DICR)=0
+8 SET D=$GET(DICR(DICR,4))
IF D=""
SET D="B"
+9 IF DIC[""""
SET Y=""
FOR A1=1:1:$LENGTH(DIC,",")-1
SET A0=$PIECE(DIC,",",A1)
IF A0[""""
SET A0=$PIECE(A0,"""")_""""""_$PIECE(A0,"""",2)_""""""_$PIECE(A0,"""",3)
SET Y=Y_A0_","
+10 ;
+11 ; Build screen to select only pointed-to entries.
+12 KILL DIC("S")
NEW DICODE
SET DICODE=""
+13 IF DIC(0)'["L"!'$DATA(DICR(DICR,"V"))
Begin DoDot:1
+14 NEW DIX
SET DIX=""""_D_""""
Begin DoDot:2
+15 IF $GET(DINDEX("#"))>1
DO BLDC^DICM0("("_DIVDIC,DIX,DINDEX("#"),DIFILEI,Y,.DICODE,.DICR)
QUIT
+16 SET DICODE="X ""I 0"" N "_%_$SELECT($DATA(DICR(DICR,"S")):",%Y"_DICR,1:"")_" "
+17 SET DICODE=DICODE_"F "_%_"=0:0 S "_%_"=$O("_DIVDIC_DIX_",(+Y_"";"_$EXTRACT(Y,2,99)_"""),"_%_")) Q:"_%_"'>0 I $D("_DIVDIC_%_",0))"
+18 IF DIC(0)["T"
IF DICR=1
SET DICODE=DICODE_$$CHKTMP^DICM0(.DIC,DICR,DIFILEI,%)
+19 IF $DATA(DICR(DICR,"S"))
SET DICODE=DICODE_" S %Y"_DICR_"=Y,Y="_%_" X DICR("_DICR_",""S"") S Y=%Y"_DICR_" I "
+20 SET DICODE=DICODE_" Q"
QUIT
End DoDot:2
+21 IF DICODE]""
SET DIC("S")=DICODE
QUIT
End DoDot:1
+22 ;
+23 ; Set DIC(0)
+24 SET %=DIC(0)
SET DIC(0)="D"_$EXTRACT("M",%'["B")
Begin DoDot:1
+25 NEW I
FOR I="E","O","B","T","V"
IF %[I
SET DIC(0)=DIC(0)_I
+26 QUIT
End DoDot:1
+27 IF %["L"
IF $DATA(DICR(DICR,"V"))
IF $$OKTOADD^DICM0(DIVDO,.DINDEX,.DIFINDER)
Begin DoDot:1
+28 IF $PIECE(DIVPDIC,U,6)="y"
SET DIC(0)=DIC(0)_"L"
+29 ; Execute screen code for screened pointer (should set DIC("S")).
+30 KILL D
IF $PIECE(DIVPDIC,U,5)'="y"
QUIT
+31 NEW DICODE
SET DICODE=$GET(^DD(DIVDO,DIVY,"V",DIVP,1))
IF DICODE=""
QUIT
+32 NEW DICSSAV
SET DICSSAV=$GET(DIC("S"))
+33 XECUTE DICODE
+34 SET DIC("S")=$GET(DIC("S"))_$SELECT(DICSSAV]"":" "_DICSSAV,1:"")
+35 QUIT
End DoDot:1
+36 IF '$TEST
KILL D
+37 ; If user passed list of indexes to use on pointed-to file, setup.
+38 SET %=$GET(DIC("PTRIX",DIFILEI,DINDEX(1,"FIELD"),+DIVPDIC))
+39 IF %]""
NEW DF,DID
SET D=%
DO SETIX^DICM0(.D,.DIC,.DID,.DF)
+40 IF $GET(D)=""
SET D="B"
NEW DISAVED
SET DISAVED=D
+41 ;
+42 ; Write prompt
+43 IF DIC(0)["E"
Begin DoDot:1
+44 IF $GET(DICODE)=""
DO H1^DIE3
IF '$DATA(DDS)
WRITE !
QUIT
+45 DO H1
QUIT
End DoDot:1
+46 ;
+47 ; Set up rest of variables needed for DQ^DICQ or ^DIC call.
+48 DO DO^DIC1
+49 NEW DS,DINDEX,DIFILEI
+50 SET D=DISAVED
KILL DISAVED
+51 ; Handle ? help
+52 IF X?."?"
Begin DoDot:1
+53 SET DZ=X_$EXTRACT("?",'$DATA(DICR(DICR,"V")))
+54 DO DQ^DICQ
SET X=$SELECT($DATA(DZ):DZ,1:"?")
SET Y=-1
QUIT
End DoDot:1
DO DQ
QUIT
+55 ; Do ^DIC call.
+56 DO X^DIC
IF $DATA(DUOUT)
DO DQ
QUIT
+57 ;
+58 ; Process output from ^DIC call.
+59 SET X=+Y_";"_$EXTRACT(DIC,2,99)
SET %=1
IF Y<0
KILL X
+60 IF Y<0
IF DIC(0)["E"
IF $DATA(DIVP1)
IF $DATA(DICR(DICR,"V"))
WRITE !
+61 IF '$DATA(DICR(DICR,"V"))!(DICR>1)
KILL DICR("^",+DIVPDIC)
SET DIVP(+DIVPDIC)=0
+62 IF Y>0
IF 'DIVPSEL(DICR)
IF DIC(0)["E"
IF '$PIECE(Y,U,3)
IF $PIECE(@(DIC_"0)"),U,2)'["O"
Begin DoDot:1
+63 NEW I
FOR I=(DICR-1):-1
IF '$DATA(DIVPSEL(I))
QUIT
SET DIVPSEL(I)=1
+64 DO S1^DIE3
IF $GET(%Y)?1"^^".E
SET (DIROUT,DUOUT)=1
+65 QUIT
End DoDot:1
DQ IF $DATA(DIC("PTRIX"))
MERGE DIV("PTRIX")=DIC("PTRIX")
+1 KILL A0,A1,DIC,DO
SET DIC=DIVDIC
SET D=$SELECT($DATA(DICR(DICR,4)):DICR(DICR,4),1:"B")
+2 SET DIC(0)=DICR(DICR,0)
+3 FOR %="V","PTRIX"
IF $DATA(DIV(%))
MERGE DIC(%)=DIV(%)
+4 QUIT
+5 ;
H1 IF '$DATA(DDS)
WRITE !
+1 NEW A1,DST,DIPAR
SET A1="T"
+2 SET DIPAR(1)=$PIECE(DIVPDIC,U,2)
SET DIPAR(2)=$PIECE($GET(^DD(DIVDO,DIVY,0)),U)
+3 SET DST=$$EZBLD^DIALOG(8097,.DIPAR)
+4 DO S^DIE3
IF '$DATA(DDS)
WRITE !
QUIT
+5 ;
+6 ;8070 Searching for a |1|
+7 ;8097 Searching for a |1|, (pointed-to by |2|)
+8 ;
