- 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 ;
