Annotation of freem_fileman/DID.m, revision 1.1
1.1 ! snw 1: DID ;SFISC/XAK-LIST DD'S ;10:11 AM 16 Dec 1994
! 2: ;;21.0;VA FileMan;;Dec 28, 1994
! 3: ;Per VHA Directive 10-93-142, this routine should not be modified.
! 4: D KL,L^DICRW1 I $D(DIC) S (DUB,DIB,DFF)=+Y G O:Y'=+DIB(1),SUB
! 5: KL K DIS,DIJS,DHIT,DIB,DINM,DIDX,DIGR,DIDH,BY,DICMX,DIOEND,FLDS
! 6: K DFF,DIFF,DID,DUB,DHD,DIC,DICS,POP,DA,DR,S,F,J,K,Z,W,X,Y,M,G,N,I
! 7: K DIWF,DIPP,DPP,DIMS,DIPQ,DJ,DDL1,DDL2,DDL3,DDLF,DDN1,X1,DDRG,I1 Q
! 8: ;
! 9: SUB S DIC="^DD("_+Y_"," G O:$O(^DD(+Y,"SB",0))'>0 S DIC(0)="AEQZ",DIC("A")=" Select SUB-FILE: ",DIC("S")="I $P(^(0),U,2)" D ^DIC G KL:$D(DTOUT) I Y>0 S (DFF,Y)=+$P(Y(0),U,2) G SUB
! 10: G KL:X[U
! 11: O K DIC S:DFF-DUB DIC("S")="I Y-5" S DIC="^DOPT(""DID"",",DIC(0)="AEQ",DIC("B")=1 D ^DIC G KL:Y<0
! 12: O1 K DIC S DIC="^DD(DFF,"
! 13: I +Y=3 S DIS(0)="I $D(^DD(DFF,D0,0))",DIOEND="G L^DIDC",DIOBEG="S L=0 I $D(DQI),DQI,$D(^UTILITY($J,2)) S ^(1.5)=""W $O(^DD(DIB,0,""""NM"""",0))_"""" FILE """""",^(2)=""X ^(1.5) ""_^(2)" D EN^DIP G KL
! 14: I +Y=4,'$D(DIFORMAT) D MOD^DID2 G KL:X[U
! 15: S L=0,FLDS="",BY="@.001" I +Y=5 S (FR,TO)=.01,DHIT="S F(1)=DUB",DHD="W """" D H1^DIDG",DIOEND="D T^DID" G G
! 16: S DHIT="D ^DID1",DHD="W """" D ^DIDH",(FR,TO)="",DIOEND="D END^DID"
! 17: I +Y=6 S DHIT="D ^DIDG",DIOEND="D END^DIDG"
! 18: I +Y=2 S DHIT="D ^DIDX",DIDX=0,%=2 I '$D(DIFORMAT) D AH^DIDX Q:%<1
! 19: I +Y=7 S DHIT="S (X1,X2)=DFF D ^DIDC",DHD="@" S DIOEND="D IOF^DID"
! 20: G Q:DIB=0 S DIOEND(1)=DIOEND,DIOEND="D LOOP^DID" D EN1^DIP G KL
! 21: LOOP I $D(Y),Y=U Q
! 22: X DIOEND(1) I $D(M),M=U Q
! 23: I IOST?1"C-".E W $C(7) R X:DTIME I X[U!'$T Q
! 24: S DN=1,D0=0,DIB=$O(^DIC(+DIB)) Q:DIB>DIB(1)!(+DIB'=DIB) S (F(1),DUB,DFF)=DIB,DC="," D ^DIO2 I $D(M),M=U Q
! 25: G LOOP
! 26: ;
! 27: END ;
! 28: I $D(^UTILITY($J,"P")) W !!!?6,"FILES POINTED TO",?44,"FIELDS",! D PTR^DIDC
! 29: D K ^UTILITY($J,"P") G IOF:DHIT["DIDX"
! 30: T ;
! 31: S S=0,M=1
! 32: T1 S S=S+1 D:$Y+3>IOSL HDR^DIDG Q:M=U
! 33: W !!,$S(S<4:$P("INPU^PRIN^SOR",U,S)_"T TEMPLATE(S):",1:"FORM(S)/BLOCK(S):")
! 34: S DFF="^DI"_$P("E^PT^BT^ST(.403)",U,S),DA=""
! 35: F S DA=$O(@DFF@("F"_F(1),DA)) Q:DA="" D Q:M=U
! 36: . S DUB=0 F S DUB=$O(@DFF@("F"_F(1),DA,DUB)) Q:'DUB D Q:M=U
! 37: .. I $D(@DFF@(DUB,0))#2 S %1=^(0) D TEMPL
! 38: K %1 G Q:M=U,T1:S<4
! 39: IOF W:IOST'?1"C".E @IOF Q
! 40: ;
! 41: TEMPL I $Y+3>IOSL D HDR^DIDG Q:M=U
! 42: W !,$P(%1,U),?30 G:DFF["DIST" FORM
! 43: S W="",Y=$P(%1,U,2) I Y D DD^%DT W Y
! 44: W ?50,"USER #"_+$P(%1,U,5),?61 I $D(@(DFF_"(DUB,""ROU"")")) W ^("ROU")_$P("*",U,DFF["DIBT")_" "
! 45: I $D(^("H")) S Y=^("H"),%=$L(Y) W:65+%>IOM ! W " ",?IOM-%-1,$E(Y,1,IOM-4)
! 46: G DES:DFF'="^DIBT"
! 47: I $D(^("DIPT")) W ?55 S Y=" '"_^("DIPT")_"' Print Template always used" W:$X+$L(Y)>IOM ! W ?IOM-$L(Y)-1,Y
! 48: I $D(^(2)) S D0=DUB,DICMX="W !?4,X" X $P(^DD(.401,1620,0),U,5,99)
! 49: F Y=1:1 Q:'$D(^DIBT(DUB,"O",Y,0)) W " " S %=^(0),D=IOM-$L(%)-5 W:$X>D !?$S(D>55:55,1:D) W %
! 50: DES N A1,%1,X S A1=$P($G(@(DFF_"(DUB,""%D"",0)")),U,3) F %1=0:0 S %1=$O(@(DFF_"(DUB,""%D"",%1)")) Q:%1'>0 Q:+A1&(%1>A1) S X=^(%1,0) W !,?5,X
! 51: Q W:DFF["DIBT" ! Q
! 52: DT G DT^DIO2
! 53: ;
! 54: EN ;
! 55: Q:'$D(DIC) I 'DIC,$D(@(DIC_"0)")) S DIC=+$P(^(0),U,2)
! 56: Q:'DIC!'$D(^DIC(DIC,0,"GL")) S (DFF,DUB,DIB,DIB(1))=DIC
! 57: G O:'$D(DIFORMAT) S Y=DIFORMAT I 'Y S Y=$O(^DOPT("DID","B",Y,0))
! 58: Q:Y>7!'Y G O1
! 59: ;
! 60: FORM ;
! 61: S Y=$P(%1,U,5) I Y D DD^%DT W ?30,Y
! 62: W ?50,"USER #"_+$P(%1,U,4)
! 63: ;
! 64: N B,L,P
! 65: S L=1,L(1)=U
! 66: S P=0 F S P=$O(^DIST(.403,DUB,40,P)) Q:'P D Q:M=U
! 67: . Q:$D(^DIST(.403,DUB,40,P,0))[0 S B=$P(^(0),U,2) D:B BLOCK Q:M=U
! 68: . S B=0 F S B=$O(^DIST(.403,DUB,40,P,40,B)) Q:'B D BLOCK Q:M=U
! 69: S %1=0 F S %1=$O(@DFF@(DUB,15,%1)) Q:'%1 W:$D(^(%1,0))#2 !?5,^(0)
! 70: W !
! 71: Q
! 72: BLOCK ;
! 73: N I
! 74: F I=1:1:L I L(I)[(U_B_U) G BLOCKQ
! 75: S:$L(L)+$L(B)+1>245 L=L+1,L(L)=U S L(L)=L(L)_B_U
! 76: Q:$D(^DIST(.404,B,0))[0 S %1=^(0)
! 77: ;
! 78: I $Y+3>IOSL D HDR^DIDG Q:M=U
! 79: W !?2,$P(%1,U) W:$P(%1,U,2)]"" ?32,"DD #"_$P(%1,U,2)
! 80: BLOCKQ Q
! 81: ;
! 82: FILELST(DIDROOT) ;
! 83: I '$D(DIQUIET) N DIQUIET S DIQUIET=1
! 84: I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
! 85: N DIDARRAY
! 86: D EN4^DIQGDD
! 87: M @DIDROOT=DIDARRAY
! 88: Q
! 89: ;
! 90: FILE(DIQGR,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;
! 91: I '$D(DIQUIET) N DIQUIET S DIQUIET=1
! 92: I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
! 93: G EN2^DIQGDD
! 94: ;
! 95: FIELDLST(DIDROOT) ;
! 96: I '$D(DIQUIET) N DIQUIET S DIQUIET=1
! 97: I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
! 98: N DIDARRAY
! 99: D EN5^DIQGDD
! 100: M @DIDROOT=DIDARRAY
! 101: Q
! 102: ;
! 103: FIELD(DIQGR,DA,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;
! 104: I '$D(DIQUIET) N DIQUIET S DIQUIET=1
! 105: I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
! 106: G EN1^DIQGDD
! 107: ;
! 108: GET1(DIQGR,DA,DIQGPARM,DR,DIQGETA,DIQGERRA,DIQGIPAR) ;
! 109: I '$D(DIQUIET) N DIQUIET S DIQUIET=1
! 110: I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
! 111: G EN3^DIQGDD
! 112: ;
! 113: PIECE(DIQGR,DA,DIQGPARM,DR,DIQGTA,DIQGERRA,DIQGIPAR) ;CLOSEDREF,PIECE,FLAG,ATTRIBUTE,TARGETARRAY,ERRORARRAY,INTERNAL
! 114: ;PROCEDURE CALL AND * * RETURN RESULTS IN TARGET ARRAY * *
! 115: I '$D(DIQUIET) N DIQUIET S DIQUIET=1
! 116: I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
! 117: G EN6^DIQGDD0
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DID.m CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem_fileman