Return to DIAXM.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Annotation of freem_fileman/USER/DIAXM.m, revision 1.1

1.1     ! snw         1: DIAXM  ;SFISC/DCM-PROCESS MAPPING INFORMATION ;6/16/93  4:04 PM
        !             2:        ;;21.0;VA FileMan;;Dec 28, 1994
        !             3:        ;Per VHA Directive 10-93-142, this routine should not be modified.
        !             4: ASK    S DIAXTAB=DL+DL-2 S:DJ DIAXTAB=DIAXTAB+1
        !             5:        I $D(DC(DC)),$P(DC(DC),U,3)]"",'DINS S DIAXDEF=$P($G(^DD(DIAXF,$P(DC(DC),U,3),0)),U)_"// "
        !             6:        W !?DIAXTAB,"MAP ",DIAXDICA," TO ",DIAXEF,$S($D(DIAXSB):" SUB-FIELD: ",1:" FIELD: ") W:'DINS $G(DIAXDEF)
        !             7:        R DIAXX:DTIME I '$T S (DTOUT,DIRUT)=1 Q
        !             8:        I DIAXX="",$D(DIAXDEF) S X=$P(DIAXDEF,"//") G ASK1
        !             9:        I DIAXX=U S (DUOUT,DIRUT)=1 Q
        !            10:        I $D(DIAXDEF),DIAXX="@" S $P(DC(DC),U,3)="" K DIAXDEF G ASK
        !            11:        I DIAXX="" W !?DIAXTAB,$C(7),DIAXDICA," will not be extracted" K DIAXDICA Q
        !            12:        S X=DIAXX
        !            13: ASK1   D DIC I Y'>0 W:X'["?" $C(7),"??",!?DIAXTAB,"Check available fields for mapping by typing '??'." G ASK
        !            14:        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
        !            15:        S DIAXLOC(DIAXFILE)=DIAXLOC(DIAXFILE)_U_+Y K:+Y=.01 DIAXE01(DIAXFILE)
        !            16:        D PR
        !            17:        Q
        !            18: DIC    K DIC,Y
        !            19:        S DIAXS1="$P(^(0),U,2)",DIC="^DD("_DIAXF_",",DIC(0)="ZE"_$E("O",DC>0)
        !            20:        D DICS
        !            21:        S DIC("S")=DIC("S")_",'$F(DIAXLOC(DIAXFILE)_U,U_+Y_U)"
        !            22:        D ^DIC
        !            23:        Q
        !            24:        ;
        !            25: DICS   I DIAXFT["W" S DIC("S")="I +"_DIAXS1_",$P(^DD(+"_DIAXS1_",.01,0),U,2)[""W""" Q
        !            26:        I DIAXFT["C" S DIC("S")="I "_DIAXS1_"[""F""!("_DIAXS1_"["""_$S(DIAXFT["D":"D"")",1:"N"")") Q
        !            27:        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:"")
        !            28:        Q
        !            29: PR     S DIAXTO=1,DIAXFR=0
        !            30:        D EN1
        !            31:        Q
        !            32: EN     S DIPG=+$G(DIPG) N DIAXF
        !            33:        W:'DIPG !!,"Excuse me, this will take a few moments...",!,"Checking the destination file...",!
        !            34:        I '$P(^DIPT(DIARP,0),U,9)!('$D(^DIC(+$P(^DIPT(DIARP,0),U,9),0))) D ERR^DIAXERR(5) Q
        !            35:        I '$D(^DIPT(DIARP,1,0)) D ERR^DIAXERR(6) Q
        !            36:        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
        !            37:        . S DIAXLNK=+$P(DIAX41,U,4),DIAXE01(DIAXF)=$S(DIAXLNK>2:+$P(DIAX41,U,3),1:DIAXDK)_U_(DIAXLNK>2)
        !            38:        . 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
        !            39:        . . K DIC S X=+DIAX42,DIC="^DD(DIAXDK,",DIC(0)="OZ" D ^DIC I Y'>0 D ERR^DIAXERR(7) Q
        !            40:        . . I $P(Y(0),U,2) S Y(0)=^DD(+$P(Y(0),U,2),.01,0)
        !            41:        . . S DIAXFR=1,DIAXTO=0,DIAXTAB=0 D EN1
        !            42:        . . K Y,DIC
        !            43:        . . I DIAXF#1 S DIAXSB=1
        !            44:        . . S X=$P(DIAX42,U,3),DIC="^DD(DIAXF,",DIC(0)="OZ" D ^DIC I Y'>0 D ERR^DIAXERR(8) K DIAXFR Q
        !            45:        . . I $P(Y(0),U,2) S Y(0)=^DD(+$P(Y(0),U,2),.01,0)
        !            46:        . . I +Y=.01 K DIAXE01(DIAXF)
        !            47:        . . D PR,Q
        !            48:        . . K DIAXSB
        !            49:        I $D(DIAXE01) D F1^DIAXMS
        !            50:        I $G(DIERR),'DIPG,DIAR=6 W !!,$C(7),"Sorry, I can not proceed with the update.  Your destination file needs fixing",!,"first."
        !            51:        I '$G(DIERR),'DIPG,DIAR="" W !,$C(7),"Template looks OK!"
        !            52:        D Q,Q1^DIAXMS
        !            53:        Q
        !            54: EN1    D IN Q:($D(DIAXMSG)&'$D(DIAR))
        !            55:        D EN^DIAXM1
        !            56:        Q
        !            57: IN     S DIAXFT=$P(Y(0),U,2),DIAXFTY=$$TYP^DIAXMS(DIAXFT) Q:($D(DIAXMSG)&'$D(DIAR))
        !            58:        S DIAXA=$S($D(DIAXVPTR):"DIAXVFR",DIAXFR:"DIAXFR",1:"DIAXTO")
        !            59:        S @(DIAXA_"(""TY"")")=DIAXFT,@(DIAXA_"(""NM"")")=Y(0,0),@(DIAXA_"(""TYP"")")=DIAXFTY
        !            60:        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)
        !            61:        Q
        !            62: Q      D Q^DIAXMS
        !            63:        Q
        !            64: EN2    S DIAXDICA=Y(0,0),DIAXFR=1,DIAXTO=0,DIAXC=C,DIAXDJ=DJ,DIAXS=S,DIPG=0,DIAXTAB=+$G(DIAXTAB)
        !            65:        D EN1 I $D(DIAXMSG)!$D(DIRUT) K Y D Q Q
        !            66:        D ASK,Q
        !            67:        Q
        !            68: HL(A,B)        S:A]"" @(DIAXA_"(""HI"")")=+A
        !            69:        S:B]"" @(DIAXA_"(""LO"")")=+B
        !            70:        Q