- DIAXMS ;SFISC/DCM-MAP SUBFILES ;9/2/94 06:17
- ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- ;;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.
- ;
- S DIAXSB=1,DIAXTAB=DL+DL-2 S:DJ DIAXTAB=DIAXTAB+1 S $P(DIAXTABZ," ",DIAXTAB)=" "
- W !,$C(7),?DIAXTAB,DIAXDICA," is a multiple valued field",!,?DIAXTAB,"It MUST be mapped to a subfile."
- K DIC,DIAXUP N Y
- I $D(DC(DC)),$P(DC(1),U,3)]"" S DIAXDEF=$P(DC(1),U,3)
- S DIC="^DD(DIAXF,",DIC(0)="QEAZ",DIC("S")="I $P(^(0),U,2),'$F(DIAXLOC(DIAXFILE)_U,U_+Y_U),$P(^DD(+$P(^(0),U,2),.01,0),U,2)'[""P"",$P(^(0),U,2)'[""W"",$P(^(0),U,2)'[""V"""
- S DIC("A")=DIAXTABZ_"MAP "_DIAXDICA_" TO "_DIAXEF_" SUBFILE: " S:$D(DIAXDEF) DIC("B")=DIAXDEF
- D ^DIC I Y'>0 S DIAXUP=1 W:X=""&'$D(DTOUT) !,$C(7),DIAXDICA_" will not be extracted" S:$D(DTOUT) DIRUT=1 G QQ
- S DIAXLOC(DIAXFILE)=DIAXLOC(DIAXFILE)_U_+Y,DIAXEF=Y(0,0)
- S (DIAXFILE,DIAXF)=+$P(Y(0),U,2),DIAXLOC(DIAXFILE)="",DIAXNP(DL-1)=$P(Y(0),U,4)
- QQ K DIAXDEF,DIAXDICA
- Q
- IX Q:$P($G(^DD($$FNO^DILIBF(DIAXF),0,"DI")),U)'["Y"
- S (DIAXIX,DIAXFI,DIAXFD)=""
- F S DIAXIX=$O(^DD(DIAXF,0,"IX",DIAXIX)) Q:DIAXIX="" F S DIAXFI=$O(^DD(DIAXF,0,"IX",DIAXIX,DIAXFI)) Q:DIAXFI'>0 F S DIAXFD=$O(^DD(DIAXF,0,"IX",DIAXIX,DIAXFI,DIAXFD)) Q:DIAXFD'>0 D
- . I '$D(^DD(DIAXFI,DIAXFD,1)) S DIAXEM="Erroneous 'IX' node for "_DIAXIX D ERR^DIAXERR(DIAXEM) Q
- . S DIAXIXN=0 F S DIAXIXN=$O(^DD(DIAXFI,DIAXFD,1,DIAXIXN)) Q:DIAXIXN'>0 S DIAXIX0=$P(^(DIAXIXN,0),U,2) Q:DIAXIX=DIAXIX0
- . Q:DIAXIXN'>0 S DIAXIX0=$P(^DD(DIAXFI,DIAXFD,1,DIAXIXN,0),U,3) D
- . . Q:DIAXIX0=""
- . . I DIAXIX0["MNE"!(DIAXIX0["REG")!(DIAXIX0["KWI")!(DIAXIX0["SOU") Q
- . . S DIAXEM="The """_DIAXIX_""" cross-reference in "_$P(^DD(DIAXFI,DIAXFD,0),U,1)_" is not allowed for an archive file." D ERR^DIAXERR(DIAXEM) Q:DIPG
- Q
- ;
- Q K DIAXZ,DIAXFT,DIAXHI,DIAXLO,DIAXNO,DIAXLE,DIAXTABZ,DIC,DIAXDICA,DIAXS,DIAXDJ,DIAXC
- K DIAXDEF,DIAXA,DIAXX,DIAXFR,DIAXTO,DIAXS1,DIAXDT,DIAXZL,DIAXZLL,DIAXZY,DIAXZZ
- K DIAXIX,DIAXIX0,DIAXIXN,DIAXVFI,DIAXVFLD,DIAXVFR,DIAXDTY
- K DIAX41,DIAX42,DIAXFTY,DIAXEXT,DIAXE1,DIAXE2,DIAXPC I '$G(DIPG),'$G(DIAR)!($G(DIAR)=6) K DIAXMSG
- Q
- Q1 K DIAXDK,DIAXDL,DIAXEF,DIAXF,DIAXFD,DIAXIX,DIAXIX0,DIAXIXN,DIAXTAB
- K DIAX1,DIAX2,DIAXFI,DIAXEM,DIAXLNK
- Q
- F1 S (A1,B1,D1)=0 S:'$D(DIAR) DIAR=""
- F S A1=$O(DIAXE01(A1)) Q:A1'>0 S B1=$G(DIAXE01(A1)),C="DIAXFR" S:+$P(B1,U,2) DIAXSB=1 D EN(B1,C) S C="DIAXTO",DIAXFR=0 D EN(A1,C) K DIAXSB
- K DIAXE01,A1,B1,D1 Q
- EN(W,Z) S @Z=1
- S DIC="^DD("_+W_",",X=.01,DIC(0)="Z",DIAXEF=$O(^DD(+W,0,"NM","")) D ^DIC I Y'>0 Q
- D EN1^DIAXM
- Q
- TYP(%) N W,W1,W2,X,Y
- S W="NPSVWCDFK",W1=%
- F X=1:1:$L(W) S W2=$F(W1,$E(W,X)) Q:W2
- S Y=$E(W1,W2-1)
- S:Y="" Y="F"
- Q Y
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIAXMS 2876 printed Feb 19, 2025@00:11:23 Page 2
- DIAXMS ;SFISC/DCM-MAP SUBFILES ;9/2/94 06:17
- +1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- +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 ;
- +7 SET DIAXSB=1
- SET DIAXTAB=DL+DL-2
- if DJ
- SET DIAXTAB=DIAXTAB+1
- SET $PIECE(DIAXTABZ," ",DIAXTAB)=" "
- +8 WRITE !,$CHAR(7),?DIAXTAB,DIAXDICA," is a multiple valued field",!,?DIAXTAB,"It MUST be mapped to a subfile."
- +9 KILL DIC,DIAXUP
- NEW Y
- +10 IF $DATA(DC(DC))
- IF $PIECE(DC(1),U,3)]""
- SET DIAXDEF=$PIECE(DC(1),U,3)
- +11 SET DIC="^DD(DIAXF,"
- SET DIC(0)="QEAZ"
- SET DIC("S")="I $P(^(0),U,2),'$F(DIAXLOC(DIAXFILE)_U,U_+Y_U),$P(^DD(+$P(^(0),U,2),.01,0),U,2)'[""P"",$P(^(0),U,2)'[""W"",$P(^(0),U,2)'[""V"""
- +12 SET DIC("A")=DIAXTABZ_"MAP "_DIAXDICA_" TO "_DIAXEF_" SUBFILE: "
- if $DATA(DIAXDEF)
- SET DIC("B")=DIAXDEF
- +13 DO ^DIC
- IF Y'>0
- SET DIAXUP=1
- if X=""&'$DATA(DTOUT)
- WRITE !,$CHAR(7),DIAXDICA_" will not be extracted"
- if $DATA(DTOUT)
- SET DIRUT=1
- GOTO QQ
- +14 SET DIAXLOC(DIAXFILE)=DIAXLOC(DIAXFILE)_U_+Y
- SET DIAXEF=Y(0,0)
- +15 SET (DIAXFILE,DIAXF)=+$PIECE(Y(0),U,2)
- SET DIAXLOC(DIAXFILE)=""
- SET DIAXNP(DL-1)=$PIECE(Y(0),U,4)
- QQ KILL DIAXDEF,DIAXDICA
- +1 QUIT
- IX if $PIECE($GET(^DD($$FNO^DILIBF(DIAXF),0,"DI")),U)'["Y"
- QUIT
- +1 SET (DIAXIX,DIAXFI,DIAXFD)=""
- +2 FOR
- SET DIAXIX=$ORDER(^DD(DIAXF,0,"IX",DIAXIX))
- if DIAXIX=""
- QUIT
- FOR
- SET DIAXFI=$ORDER(^DD(DIAXF,0,"IX",DIAXIX,DIAXFI))
- if DIAXFI'>0
- QUIT
- FOR
- SET DIAXFD=$ORDER(^DD(DIAXF,0,"IX",DIAXIX,DIAXFI,DIAXFD))
- if DIAXFD'>0
- QUIT
- Begin DoDot:1
- +3 IF '$DATA(^DD(DIAXFI,DIAXFD,1))
- SET DIAXEM="Erroneous 'IX' node for "_DIAXIX
- DO ERR^DIAXERR(DIAXEM)
- QUIT
- +4 SET DIAXIXN=0
- FOR
- SET DIAXIXN=$ORDER(^DD(DIAXFI,DIAXFD,1,DIAXIXN))
- if DIAXIXN'>0
- QUIT
- SET DIAXIX0=$PIECE(^(DIAXIXN,0),U,2)
- if DIAXIX=DIAXIX0
- QUIT
- +5 if DIAXIXN'>0
- QUIT
- SET DIAXIX0=$PIECE(^DD(DIAXFI,DIAXFD,1,DIAXIXN,0),U,3)
- Begin DoDot:2
- +6 if DIAXIX0=""
- QUIT
- +7 IF DIAXIX0["MNE"!(DIAXIX0["REG")!(DIAXIX0["KWI")!(DIAXIX0["SOU")
- QUIT
- +8 SET DIAXEM="The """_DIAXIX_""" cross-reference in "_$PIECE(^DD(DIAXFI,DIAXFD,0),U,1)_" is not allowed for an archive file."
- DO ERR^DIAXERR(DIAXEM)
- if DIPG
- QUIT
- End DoDot:2
- End DoDot:1
- +9 QUIT
- +10 ;
- Q KILL DIAXZ,DIAXFT,DIAXHI,DIAXLO,DIAXNO,DIAXLE,DIAXTABZ,DIC,DIAXDICA,DIAXS,DIAXDJ,DIAXC
- +1 KILL DIAXDEF,DIAXA,DIAXX,DIAXFR,DIAXTO,DIAXS1,DIAXDT,DIAXZL,DIAXZLL,DIAXZY,DIAXZZ
- +2 KILL DIAXIX,DIAXIX0,DIAXIXN,DIAXVFI,DIAXVFLD,DIAXVFR,DIAXDTY
- +3 KILL DIAX41,DIAX42,DIAXFTY,DIAXEXT,DIAXE1,DIAXE2,DIAXPC
- IF '$GET(DIPG)
- IF '$GET(DIAR)!($GET(DIAR)=6)
- KILL DIAXMSG
- +4 QUIT
- Q1 KILL DIAXDK,DIAXDL,DIAXEF,DIAXF,DIAXFD,DIAXIX,DIAXIX0,DIAXIXN,DIAXTAB
- +1 KILL DIAX1,DIAX2,DIAXFI,DIAXEM,DIAXLNK
- +2 QUIT
- F1 SET (A1,B1,D1)=0
- if '$DATA(DIAR)
- SET DIAR=""
- +1 FOR
- SET A1=$ORDER(DIAXE01(A1))
- if A1'>0
- QUIT
- SET B1=$GET(DIAXE01(A1))
- SET C="DIAXFR"
- if +$PIECE(B1,U,2)
- SET DIAXSB=1
- DO EN(B1,C)
- SET C="DIAXTO"
- SET DIAXFR=0
- DO EN(A1,C)
- KILL DIAXSB
- +2 KILL DIAXE01,A1,B1,D1
- QUIT
- EN(W,Z) SET @Z=1
- +1 SET DIC="^DD("_+W_","
- SET X=.01
- SET DIC(0)="Z"
- SET DIAXEF=$ORDER(^DD(+W,0,"NM",""))
- DO ^DIC
- IF Y'>0
- QUIT
- +2 DO EN1^DIAXM
- +3 QUIT
- TYP(%) NEW W,W1,W2,X,Y
- +1 SET W="NPSVWCDFK"
- SET W1=%
- +2 FOR X=1:1:$LENGTH(W)
- SET W2=$FIND(W1,$EXTRACT(W,X))
- if W2
- QUIT
- +3 SET Y=$EXTRACT(W1,W2-1)
- +4 if Y=""
- SET Y="F"
- +5 QUIT Y
