DIAXM ;SFISC/DCM-PROCESS MAPPING INFORMATION ;6/16/93 4:04 PM
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
ASK S DIAXTAB=DL+DL-2 S:DJ DIAXTAB=DIAXTAB+1
I $D(DC(DC)),$P(DC(DC),U,3)]"",'DINS S DIAXDEF=$P($G(^DD(DIAXF,$P(DC(DC),U,3),0)),U)_"// "
W !?DIAXTAB,"MAP ",DIAXDICA," TO ",DIAXEF,$S($D(DIAXSB):" SUB-FIELD: ",1:" FIELD: ") W:'DINS $G(DIAXDEF)
R DIAXX:DTIME I '$T S (DTOUT,DIRUT)=1 Q
I DIAXX="",$D(DIAXDEF) S X=$P(DIAXDEF,"//") G ASK1
I DIAXX=U S (DUOUT,DIRUT)=1 Q
I $D(DIAXDEF),DIAXX="@" S $P(DC(DC),U,3)="" K DIAXDEF G ASK
I DIAXX="" W !?DIAXTAB,$C(7),DIAXDICA," will not be extracted" K DIAXDICA Q
S X=DIAXX
ASK1 D DIC I Y'>0 W:X'["?" $C(7),"??",!?DIAXTAB,"Check available fields for mapping by typing '??'." G ASK
I +$P(Y(0),U,2),$P(^DD(+$P(Y(0),U,2),.01,0),U,2)["W" S DIAX1=$P(Y(0),U,4),Y(0)=^(0),$P(Y(0),U,4)=DIAX1
S DIAXLOC(DIAXFILE)=DIAXLOC(DIAXFILE)_U_+Y K:+Y=.01 DIAXE01(DIAXFILE)
D PR
Q
DIC K DIC,Y
S DIAXS1="$P(^(0),U,2)",DIC="^DD("_DIAXF_",",DIC(0)="ZE"_$E("O",DC>0)
D DICS
S DIC("S")=DIC("S")_",'$F(DIAXLOC(DIAXFILE)_U,U_+Y_U)"
D ^DIC
Q
;
DICS I DIAXFT["W" S DIC("S")="I +"_DIAXS1_",$P(^DD(+"_DIAXS1_",.01,0),U,2)[""W""" Q
I DIAXFT["C" S DIC("S")="I "_DIAXS1_"[""F""!("_DIAXS1_"["""_$S(DIAXFT["D":"D"")",1:"N"")") Q
S DIC("S")="I "_DIAXS1_"["""_$S(DIAXFT["K":"K""",1:"F""")_$S(DIAXFT["D":"!("_DIAXS1_"[""D"")",DIAXFT["N"!(DIAXFT["P"&'$G(DIAXEXT)):"!("_DIAXS1_"[""N"")",1:"")_$S((DIAXFT["S"&'$G(DIAXEXT)):"!("_DIAXS1_"[""S"")",1:"")
Q
PR S DIAXTO=1,DIAXFR=0
D EN1
Q
EN S DIPG=+$G(DIPG) N DIAXF
W:'DIPG !!,"Excuse me, this will take a few moments...",!,"Checking the destination file...",!
I '$P(^DIPT(DIARP,0),U,9)!('$D(^DIC(+$P(^DIPT(DIARP,0),U,9),0))) D ERR^DIAXERR(5) Q
I '$D(^DIPT(DIARP,1,0)) D ERR^DIAXERR(6) Q
F DIAX1=0:0 S DIAX1=$O(^DIPT(DIARP,1,DIAX1)) Q:DIAX1'>0 S DIAX41=^(DIAX1,0),(DIAXDK,DK)=+DIAX41,DIAXDL=$P(DIAX41,U,2),DIAXF=$P(DIAX41,U,9),DIAXEF=$O(^DD(DIAXF,0,"NM",0)) D D IX^DIAXMS
. S DIAXLNK=+$P(DIAX41,U,4),DIAXE01(DIAXF)=$S(DIAXLNK>2:+$P(DIAX41,U,3),1:DIAXDK)_U_(DIAXLNK>2)
. F DIAX2=0:0 S DIAX2=$O(^DIPT(DIARP,1,DIAX1,"F",DIAX2)) Q:DIAX2'>0 S DIAX42=^(DIAX2,0),DIAXEXT=+$P(DIAX42,U,5) D
. . K DIC S X=+DIAX42,DIC="^DD(DIAXDK,",DIC(0)="OZ" D ^DIC I Y'>0 D ERR^DIAXERR(7) Q
. . I $P(Y(0),U,2) S Y(0)=^DD(+$P(Y(0),U,2),.01,0)
. . S DIAXFR=1,DIAXTO=0,DIAXTAB=0 D EN1
. . K Y,DIC
. . I DIAXF#1 S DIAXSB=1
. . S X=$P(DIAX42,U,3),DIC="^DD(DIAXF,",DIC(0)="OZ" D ^DIC I Y'>0 D ERR^DIAXERR(8) K DIAXFR Q
. . I $P(Y(0),U,2) S Y(0)=^DD(+$P(Y(0),U,2),.01,0)
. . I +Y=.01 K DIAXE01(DIAXF)
. . D PR,Q
. . K DIAXSB
I $D(DIAXE01) D F1^DIAXMS
I $G(DIERR),'DIPG,DIAR=6 W !!,$C(7),"Sorry, I can not proceed with the update. Your destination file needs fixing",!,"first."
I '$G(DIERR),'DIPG,DIAR="" W !,$C(7),"Template looks OK!"
D Q,Q1^DIAXMS
Q
EN1 D IN Q:($D(DIAXMSG)&'$D(DIAR))
D EN^DIAXM1
Q
IN S DIAXFT=$P(Y(0),U,2),DIAXFTY=$$TYP^DIAXMS(DIAXFT) Q:($D(DIAXMSG)&'$D(DIAR))
S DIAXA=$S($D(DIAXVPTR):"DIAXVFR",DIAXFR:"DIAXFR",1:"DIAXTO")
S @(DIAXA_"(""TY"")")=DIAXFT,@(DIAXA_"(""NM"")")=Y(0,0),@(DIAXA_"(""TYP"")")=DIAXFTY
I "FN"[DIAXFTY S DIAXHI=+$P($P(Y(0),U,5,9),">",2),DIAXLO=+$P($P(Y(0),U,5,9),"<",2) D HL(DIAXHI,DIAXLO)
Q
Q D Q^DIAXMS
Q
EN2 S DIAXDICA=Y(0,0),DIAXFR=1,DIAXTO=0,DIAXC=C,DIAXDJ=DJ,DIAXS=S,DIPG=0,DIAXTAB=+$G(DIAXTAB)
D EN1 I $D(DIAXMSG)!$D(DIRUT) K Y D Q Q
D ASK,Q
Q
HL(A,B) S:A]"" @(DIAXA_"(""HI"")")=+A
S:B]"" @(DIAXA_"(""LO"")")=+B
Q
DIAXM ;SFISC/DCM-PROCESS MAPPING INFORMATION ;6/16/93 4:04 PM
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
ASK SET DIAXTAB=DL+DL-2
IF DJ
SET DIAXTAB=DIAXTAB+1
+1 IF $DATA(DC(DC))
IF $PIECE(DC(DC),U,3)]""
IF 'DINS
SET DIAXDEF=$PIECE($GET(^DD(DIAXF,$PIECE(DC(DC),U,3),0)),U)_"// "
+2 WRITE !?DIAXTAB,"MAP ",DIAXDICA," TO ",DIAXEF,$SELECT($DATA(DIAXSB):" SUB-FIELD: ",1:" FIELD: ")
IF 'DINS
WRITE $GET(DIAXDEF)
+3 READ DIAXX:DTIME
IF '$TEST
SET (DTOUT,DIRUT)=1
QUIT
+4 IF DIAXX=""
IF $DATA(DIAXDEF)
SET X=$PIECE(DIAXDEF,"//")
GOTO ASK1
+5 IF DIAXX=U
SET (DUOUT,DIRUT)=1
QUIT
+6 IF $DATA(DIAXDEF)
IF DIAXX="@"
SET $PIECE(DC(DC),U,3)=""
KILL DIAXDEF
GOTO ASK
+7 IF DIAXX=""
WRITE !?DIAXTAB,$CHAR(7),DIAXDICA," will not be extracted"
KILL DIAXDICA
QUIT
+8 SET X=DIAXX
ASK1 DO DIC
IF Y'>0
IF X'["?"
WRITE $CHAR(7),"??",!?DIAXTAB,"Check available fields for mapping by typing '??'."
GOTO ASK
+1 IF +$PIECE(Y(0),U,2)
IF $PIECE(^DD(+$PIECE(Y(0),U,2),.01,0),U,2)["W"
SET DIAX1=$PIECE(Y(0),U,4)
SET Y(0)=^(0)
SET $PIECE(Y(0),U,4)=DIAX1
+2 SET DIAXLOC(DIAXFILE)=DIAXLOC(DIAXFILE)_U_+Y
IF +Y=.01
KILL DIAXE01(DIAXFILE)
+3 DO PR
+4 QUIT
DIC KILL DIC,Y
+1 SET DIAXS1="$P(^(0),U,2)"
SET DIC="^DD("_DIAXF_","
SET DIC(0)="ZE"_$EXTRACT("O",DC>0)
+2 DO DICS
+3 SET DIC("S")=DIC("S")_",'$F(DIAXLOC(DIAXFILE)_U,U_+Y_U)"
+4 DO ^DIC
+5 QUIT
+6 ;
DICS IF DIAXFT["W"
SET DIC("S")="I +"_DIAXS1_",$P(^DD(+"_DIAXS1_",.01,0),U,2)[""W"""
QUIT
+1 IF DIAXFT["C"
SET DIC("S")="I "_DIAXS1_"[""F""!("_DIAXS1_"["""_$SELECT(DIAXFT["D":"D"")",1:"N"")")
QUIT
+2 SET DIC("S")="I "_DIAXS1_"["""_$SELECT(DIAXFT["K":"K""",1:"F""")_$SELECT(DIAXFT["D":"!("_DIAXS1_"[""D"")",DIAXFT["N"!(DIAXFT["P"&'$GET(DIAXEXT)):"!("_DIAXS1_"[""N"")",1:"")_$SELECT((DIAXFT["S"&'$GET(DIAXEXT)):"!("_DIAXS1_"[""S"")",1:"")
+3 QUIT
PR SET DIAXTO=1
SET DIAXFR=0
+1 DO EN1
+2 QUIT
EN SET DIPG=+$GET(DIPG)
NEW DIAXF
+1 IF 'DIPG
WRITE !!,"Excuse me, this will take a few moments...",!,"Checking the destination file...",!
+2 IF '$PIECE(^DIPT(DIARP,0),U,9)!('$DATA(^DIC(+$PIECE(^DIPT(DIARP,0),U,9),0)))
DO ERR^DIAXERR(5)
QUIT
+3 IF '$DATA(^DIPT(DIARP,1,0))
DO ERR^DIAXERR(6)
QUIT
+4 FOR DIAX1=0:0
SET DIAX1=$ORDER(^DIPT(DIARP,1,DIAX1))
IF DIAX1'>0
QUIT
SET DIAX41=^(DIAX1,0)
SET (DIAXDK,DK)=+DIAX41
SET DIAXDL=$PIECE(DIAX41,U,2)
SET DIAXF=$PIECE(DIAX41,U,9)
SET DIAXEF=$ORDER(^DD(DIAXF,0,"NM",0))
Begin DoDot:1
+5 SET DIAXLNK=+$PIECE(DIAX41,U,4)
SET DIAXE01(DIAXF)=$SELECT(DIAXLNK>2:+$PIECE(DIAX41,U,3),1:DIAXDK)_U_(DIAXLNK>2)
+6 FOR DIAX2=0:0
SET DIAX2=$ORDER(^DIPT(DIARP,1,DIAX1,"F",DIAX2))
IF DIAX2'>0
QUIT
SET DIAX42=^(DIAX2,0)
SET DIAXEXT=+$PIECE(DIAX42,U,5)
Begin DoDot:2
+7 KILL DIC
SET X=+DIAX42
SET DIC="^DD(DIAXDK,"
SET DIC(0)="OZ"
DO ^DIC
IF Y'>0
DO ERR^DIAXERR(7)
QUIT
+8 IF $PIECE(Y(0),U,2)
SET Y(0)=^DD(+$PIECE(Y(0),U,2),.01,0)
+9 SET DIAXFR=1
SET DIAXTO=0
SET DIAXTAB=0
DO EN1
+10 KILL Y,DIC
+11 IF DIAXF#1
SET DIAXSB=1
+12 SET X=$PIECE(DIAX42,U,3)
SET DIC="^DD(DIAXF,"
SET DIC(0)="OZ"
DO ^DIC
IF Y'>0
DO ERR^DIAXERR(8)
KILL DIAXFR
QUIT
+13 IF $PIECE(Y(0),U,2)
SET Y(0)=^DD(+$PIECE(Y(0),U,2),.01,0)
+14 IF +Y=.01
KILL DIAXE01(DIAXF)
+15 DO PR
DO Q
+16 KILL DIAXSB
End DoDot:2
End DoDot:1
DO IX^DIAXMS
+17 IF $DATA(DIAXE01)
DO F1^DIAXMS
+18 IF $GET(DIERR)
IF 'DIPG
IF DIAR=6
WRITE !!,$CHAR(7),"Sorry, I can not proceed with the update. Your destination file needs fixing",!,"first."
+19 IF '$GET(DIERR)
IF 'DIPG
IF DIAR=""
WRITE !,$CHAR(7),"Template looks OK!"
+20 DO Q
DO Q1^DIAXMS
+21 QUIT
EN1 DO IN
IF ($DATA(DIAXMSG)&'$DATA(DIAR))
QUIT
+1 DO EN^DIAXM1
+2 QUIT
IN SET DIAXFT=$PIECE(Y(0),U,2)
SET DIAXFTY=$$TYP^DIAXMS(DIAXFT)
IF ($DATA(DIAXMSG)&'$DATA(DIAR))
QUIT
+1 SET DIAXA=$SELECT($DATA(DIAXVPTR):"DIAXVFR",DIAXFR:"DIAXFR",1:"DIAXTO")
+2 SET @(DIAXA_"(""TY"")")=DIAXFT
SET @(DIAXA_"(""NM"")")=Y(0,0)
SET @(DIAXA_"(""TYP"")")=DIAXFTY
+3 IF "FN"[DIAXFTY
SET DIAXHI=+$PIECE($PIECE(Y(0),U,5,9),">",2)
SET DIAXLO=+$PIECE($PIECE(Y(0),U,5,9),"<",2)
DO HL(DIAXHI,DIAXLO)
+4 QUIT
Q DO Q^DIAXMS
+1 QUIT
EN2 SET DIAXDICA=Y(0,0)
SET DIAXFR=1
SET DIAXTO=0
SET DIAXC=C
SET DIAXDJ=DJ
SET DIAXS=S
SET DIPG=0
SET DIAXTAB=+$GET(DIAXTAB)
+1 DO EN1
IF $DATA(DIAXMSG)!$DATA(DIRUT)
KILL Y
DO Q
QUIT
+2 DO ASK
DO Q
+3 QUIT
HL(A,B) IF A]""
SET @(DIAXA_"(""HI"")")=+A
+1 IF B]""
SET @(DIAXA_"(""LO"")")=+B
+2 QUIT
