Return to DIP11.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DIP11.m, revision 1.1

1.1     ! snw         1: DIP11  ;SFISC/XAK,TKW-GET SORT TEMPLATE ;8/26/94  15:36
        !             2:        ;;21.0;VA FileMan;;Dec 28, 1994
        !             3:        ;Per VHA Directive 10-93-142, this routine should not be modified.
        !             4: TEM    ;
        !             5:        I DJ-1 G B^DIP:$G(BY(0))="" I DJ>(DPP(0)+1) G B^DIP
        !             6:        K DIC F %=DJ:0 K DPP(%) S %=$O(DPP(%)) Q:'%
        !             7:        S X=$P($E(X,2,99),"]",1),DIC(0)="ZQS"_$E("E",'($D(BY)#2)!''L),DIC="^DIBT(",D="F"_DL
        !             8:        S DIC("S")="I $P(^(0),U,4)=DL,$S(L=0:1,'$D(^(1)):1,'$P(^(0),U,5):1,1:$P(^(0),U,5)=DUZ)"
        !             9:        I X?."?" S:X'?1"???" X="??" D IX^DIC S DJ=$G(DPP(0)) Q
        !            10:        D ^DIC I Y<0 S DJ=$G(DPP(0)) Q
        !            11:        I $D(^DIBT(+Y,"DIS")),'$D(^(1)) W:'$G(DIQUIET) !,"This SEARCH template has no search results!" S DJ=$G(DPP(0)) Q
        !            12:        S DPP(DJ)=DL_"^^'"_$P(Y,U,2)_"' NUMBER^@'"_P,(DIBT1,X)=+Y,DIBT2=$P(Y(0),U),D=DIC_X_C K DIC
        !            13:        I '$D(FLDS),$G(^DIBT(X,"DIPT"))]"" S FLDS="["_^("DIPT")_"]" I L D
        !            14:        . N %,A S %(1)=^("DIPT") D BLD^DIALOG(8030,.%,"","A") W ! F %=0:0 S %=$O(A(%)) Q:'%  W A(%),!
        !            15:        . S L=0 Q
        !            16:        I $D(^DIBT(X,1)) S DIC=D_1_C,DPP(DJ,"SER")="998^998" D ENT^DIP10(DJ,DIBT1) I $D(^DIBT(X,1)) S Y=1 D
        !            17:        .F DY=1:1 S Y=$O(^(Y,-1)) S:Y="" Y=-1 S:$O(^(Y)) Y=$O(^(Y)) I $D(^(Y))<9 S DPP(DJ,"IX")=DIC_DI_U_DY,DIBT=X Q
        !            18:        .Q
        !            19: ENDIPT Q:'$D(^DIBT(X,2))  I $G(^DIBT(X,2,0))="" S %Y="DPP(",%X=D_2_C D %XY^%RCR S DIBTOLD="" D CNVCM G T0
        !            20:        F D=0:0 S D=$O(^DIBT(X,2,D)) Q:'D  D
        !            21:        .N A,B,C S DPP(DJ)=^DIBT(X,2,D,0)
        !            22:        .S A="A" F  S A=$O(^DIBT(X,2,D,A)) Q:A=""  S DPP(DJ,A)=^(A)
        !            23:        .F B=1,2,3 F A=0:0 S A=$O(^DIBT(X,2,D,B,A)) Q:'A  S C=$G(^(A,0)) D
        !            24:        ..I B=1 S:C DPP(DJ,+C)=$P(C,U,2) Q
        !            25:        ..I B=2 S:C&($P(C,U,2)) DPP(DJ,+C,+$P(C,U,2))=$P(C,U,3,7)_U_$G(^DIBT(X,2,D,2,A,"RCOD")) Q
        !            26:        ..I $P(C,U,1)]"",$P(C,U,2)]"" S DPP(DJ,$P(C,U,1),$P(C,U,2))=$G(^DIBT(X,2,D,3,A,"OVF0"))
        !            27:        ..Q
        !            28:        .S DJ=DJ+1 Q
        !            29: T0     Q:$D(DIBTRPT)
        !            30:        I $D(DIAR) S DIARU=X ;I '$P(DIARB,U,2) S $P(DIARB,U,2)=DIARU
        !            31:        F D=0:0 S D=$O(^DIBT(X,3,D)) Q:D=""  S DSC(D)=^(D)
        !            32:        G T1:'L S %=$P(^DIBT(X,0),U,6)
        !            33:        I %]"" F D=1:1:$L(%) I DUZ(0)[$E(%,D)!(DUZ(0)="@") S %="" Q
        !            34:        I %="",X'<1 S %=$P(Y(0),U,1) D  G Q:$D(DIRUT) I %=1 K DIBTOLD G EDT^DIP0
        !            35:        . N X,Y K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="WANT TO EDIT '"_%_"' TEMPLATE" D ^DIR K DIR
        !            36:        . S %=Y Q
        !            37: T1     F DJ=$G(DPP(0))+1:1 Q:'$D(DPP(DJ))  D  I '$D(DJ)!($D(DTOUT))!($D(DIRUT)) G Q
        !            38:        . N DL,DU,DV,X,Y,Z,DIBTLIST,DIFLD,DIFLDREG K DPP(DJ,"SRTTXT"),DPP(DJ,"PTRIX") S DL=$P(DPP(DJ),U),Y=$P(DPP(DJ),U,2,3),DIBTLIST=""
        !            39:        . S Z=$P($G(DPP(DJ,"IX")),U,2) I Z]"" S Z(1)=$E($G(^DIC(+DL,0,"GL")),2,999) I Z(1)'=$E(Z,1,$L(Z(1))) S DIBTLIST=1
        !            40:        . I DIBTLIST S $P(DPP(DJ),U,2)=0,DPP(DJ,"SER")="998^998",DPP(DJ,"GET")="",DPP(DJ,"QCON")="I D0'=""""",DPP(DJ,"TXT")="Sort using ^"_Z K DPP(DJ,"ASK") Q
        !            41:        . D DTYP^DIP1,STXT^DIP1(DJ,$G(DPP(DJ,"F")),$G(DPP(DJ,"T")),DITYP)
        !            42:        . K DPP(DJ,"IX") I $P(DPP(DJ),U,4)'["-",'$D(DPP(DJ,"SRTTXT")),$P($G(DPP(DJ,"F")),U,2)'="@",$P($G(DPP(DJ,"T")),U,2)'="@" D XR^DIP
        !            43:        . I $D(DPP(DJ,"ASK")) S DPP(DJ,"ASK")=1 I $G(DICNVDPP)'=1 K DPP(DJ,"F"),DPP(DJ,"T"),DIARS,DIARE D J^DIP1 Q
        !            44:        . D OPT^DIP12 Q
        !            45:        Q:$G(DICNVDPP)=1
        !            46:        D DPQ^DIP1 S X="["_DIBT2 K DIARE,DIARS,DIARB Q
        !            47:        ;
        !            48: CNVCM  ;Convert V20 DPP array to V21 DPP array (for prints queued in V20 to run in V21)
        !            49:        N D,I,J,X,Y,Z,N
        !            50:        F D=0:0 S D=$O(DPP(D)) Q:'D  S X=$G(DPP(D,"CM")) I X["S X(" D
        !            51:        . S (I,Z)=0 F  S Y=$F(X,"S X(",Z) Q:'Y  S Z=Y,I=I+1
        !            52:        . Q:'Z  S N=+$E(X,Z) Q:'N
        !            53:        . I $L(X)+16>248 D  Q
        !            54:        .. S Z="OVF",I=-1 F  S Z=$O(DPP(D,Z)) Q:$E(Z,1,3)'="OVF"  S I=$E(Z,4,99)
        !            55:        .. S Z="OVF"_(I+1),Y=$P(X," S X=",1) S:Y]"" Y=Y_" "
        !            56:        .. S DPP(D,"CM")=Y_"X DPP("_D_","""_Z_""",9.2) I $G(X("_N_"))]"""" S DISX("_N_")=X("_N_")"
        !            57:        .. S Y=$P(X," S X=",2,99),DPP(D,Z,9.2)=$P("S X=",U,(Y]""))_Y Q
        !            58:        . S DPP(D,"CM")=$P(X,"S X(",1,I)_"S DISX("_$P(X,"S X(",I+1,99)
        !            59:        . Q
        !            60:        Q
        !            61:        ;
        !            62: Q      S:$D(DUOUT)!($D(DTOUT)) X="^" G Q^DIP
        !            63:        ;DIALOG #8030  'Because...sort template...linked w/Print template...