- DIAXM ;SFISC/DCM-PROCESS MAPPING INFORMATION ;6/16/93 4:04 PM
- ;;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.
- ;
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIAXM 3770 printed Feb 19, 2025@00:11:19 Page 2
- DIAXM ;SFISC/DCM-PROCESS MAPPING INFORMATION ;6/16/93 4:04 PM
- +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 ;
- 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
