Return to DIFROMSS.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

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

1.1     ! snw         1: DIFROMSS       ;SCISC/DCL-DIFROM SERVER/DATA SORT LIST/SB-DD/HDR2P ;11:05 AM  15 Sep 1994;
        !             2:        ;;21.0;VA FileMan;;Dec 28, 1994
        !             3:        ;Per VHA Directive 10-93-142, this routine should not be modified.
        !             4:        Q
        !             5: SEL(DIFRFILE,DIFRX)    ;Extrinsic function to return resolved value for
        !             6:        ;freetext pointer
        !             7:        ;FILE,X-VALUE
        !             8:        N D,DIC,DIE,DIX,DIY,DO,DS,X,Y
        !             9:        N %,%K,%Y,DA,D0,D1,D2,D3
        !            10:        S DIC="^DIBT(",DIC(0)="QEMZ",X=DIFRX
        !            11:        S DIC("S")="I $P(^(0),U,4)=DIFRFILE,$D(^(1))>9"
        !            12:        D ^DIC
        !            13:        Q:Y'>0 ""
        !            14:        Q Y(0,0)
        !            15:        ;
        !            16: HELP(DIFRFILE) ;
        !            17:        N D,DIC,DIE,DIX,DIY,DO,DS,X,Y
        !            18:        N %,%K,%Y,DA,D0,D1,D2,D3
        !            19:        S DIC="^DIBT(",DIC(0)="M",DIC("S")="I $P(^(0),U,4)=DIFRFILE,$D(^(1))>9",X="??"
        !            20:        D ^DIC
        !            21:        Q
        !            22:        ;
        !            23: SB(DIFRDD,DIFRFLG,DIFRTA,DIFRVAL)      ;Returns a list of sub-DDs for any DD#
        !            24:        ;DD#,FLAGS,TARGET ARRAY(by value)
        !            25:        ;DD/SUB DD NUMBER (required)
        !            26:        ;FLAGS "W"=Include Word-processing fields (optional)
        !            27:        ;TARGET ARRAY (required)
        !            28:        ;DIFRVAL - SET TARGET ARRAY EQUAL TO
        !            29:        N DIFRSDD,DIFRSSDD,DIFRNW
        !            30:        S DIFRSDD=0,DIFRNW=$G(DIFRFLG)'["W",DIFRVAL=$G(DIFRVAL)
        !            31:        F  S DIFRSDD=$O(^DD(DIFRDD,"SB",DIFRSDD)) Q:DIFRSDD'>0  D
        !            32:        .S DIFRSSDD=0
        !            33:        .I DIFRNW,$P($G(^DD(DIFRSDD,.01,0)),"^",2)["W" Q
        !            34:        .S @DIFRTA@(DIFRSDD)=DIFRVAL,DIFRSSDD=$O(^DD(DIFRSDD,"SB",0))
        !            35:        .I DIFRSSDD D SB(DIFRSDD,$G(DIFRFLG),DIFRTA,DIFRVAL)
        !            36:        .Q
        !            37:        Q
        !            38:        ;
        !            39: HDR2P(DIFRDD)  ;Header Node/2nd piece update
        !            40:        Q:$G(DIFRDD)'>0 ""
        !            41:        Q:'$D(^DIC(+DIFRDD,0,"GL")) "" S DIFRDD=$TR(DIFRDD_$P($P(@(^("GL")_"0)"),"^",2),+DIFRDD,2),"DPSVIs")
        !            42:        N DIFRDDT
        !            43:        I $O(^DD(+DIFRDD,0,"ID",0)) S DIFRDD=DIFRDD_"I"
        !            44:        I $D(^DD(+DIFRDD,0,"SCR")) S DIFRDD=DIFRDD_"s"
        !            45:        F DIFRDDT="D","P","S","V" I $P(^DD(+DIFRDD,.01,0),"^",2)[DIFRDDT S DIFRDD=DIFRDD_DIFRDDT Q
        !            46:        Q DIFRDD
        !            47:        ;
        !            48: EXAM(TA)       ;Examine what's in 2nd piece of data Header and put into array sub
        !            49:        ;TA=Target Array
        !            50:        Q:$G(TA)']""
        !            51:        N FN,GR,P2
        !            52:        S FN=0
        !            53:        F  S FN=$O(^DIC(FN)) Q:FN'>0  I $D(^DIC(FN,0,"GL")) S GR=^("GL") D
        !            54:        .Q:'$D(@(GR_"0)"))  S P2=$P(^(0),"^",2),P2=$P(P2,+P2,2)
        !            55:        .S:P2]"" @TA@(P2)=FN
        !            56:        .Q
        !            57:        Q
        !            58:        ;
        !            59: VAL(DIFRFILE,DIFRIEN)  ;Validate Edit and Print Template's and also Forms
        !            60:        S DIFRFILE=$G(DIFRFILE),DIFRIEN=$G(DIFRIEN)
        !            61:        Q:DIFRIEN'>0 0
        !            62:        N ROOT,PIECE,FILE
        !            63:        D
        !            64:        .N X
        !            65:        .S X=DIFRFILE
        !            66:        .I X=.4!(X=.402)!(X=.403)!(X=.404) Q
        !            67:        .S DIFRFILE=0
        !            68:        .Q
        !            69:        Q:DIFRFILE'>0 0
        !            70:        S ROOT="^"_$P($P(".4;DIPT^.402;DIE^.403;DIST(.403)^.404;DIST(.404)",DIFRFILE_";",2),"^")
        !            71:        S PIECE=$P($P(".4;4^.402;4^.403;8^.404;2",DIFRFILE_";",2),"^")
        !            72:        Q:'$D(@ROOT@(DIFRIEN,0)) 0
        !            73:        S FILE=$P(^(0),"^",PIECE)
        !            74:        I DIFRFILE=.404&('FILE) Q 1
        !            75:        Q:FILE'>0 0
        !            76:        I DIFRFILE=.403 N BLOCK D  Q:'BLOCK 0
        !            77:        .N PAGE,BLOCKP
        !            78:        .S PAGE=0,BLOCK=1
        !            79:        .F  S PAGE=$O(@ROOT@(DIFRIEN,40,PAGE)) Q:PAGE'>0  S BLOCKP=$P($G(^(PAGE,0)),"^",2) S:BLOCKP BLOCK=$$VAL(.404,BLOCKP) Q:'BLOCK  D  Q:'BLOCK
        !            80:        ..N M40
        !            81:        ..S M40=0
        !            82:        ..F  S M40=$O(@ROOT@(DIFRIEN,40,PAGE,40,M40)) Q:M40'>0  S BLOCK=$$VAL(.404,M40) Q:'BLOCK
        !            83:        ..Q
        !            84:        .Q
        !            85:        I DIFRFILE=.4,$P(@ROOT@(DIFRIEN,0),"^",8) Q 0
        !            86:        Q $D(^DD(FILE,0))#2