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 Dec 13, 2024@02:45:08 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
