Return to DIFGB.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DIFGB	;SFISC/XAK-STORE FILEGRAM TEMPLATE ;10/14/92  8:10 AM
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: PUT	;
    5: 	W !,"STORE ",$S($D(DIAR):"ARCHIVE",$D(DIAX):"EXTRACT",1:"FILEGRAM")_" LOGIC IN TEMPLATE: "
    6: 	R X:DTIME S:'$T DTOUT=1,X="" G Q:U[X
    7: 	S DIC="^DIPT(",D="F"_DK
    8: 	S DIC("S")="S %=^(0) I $P(%,U,8)="_$S($D(DIAX):2,1:1)_",$P(%,U,4)=DK!'$L($P(%,U,4))"_$P(" F DW=1:1:$L($P(%,U,3)) I DUZ(0)[$E($P(%,U,3),DW) Q",U,DUZ(0)'="@"&L)
    9: 	S DIC(0)="ELZSQI",DIC("S")="I Y'<1 "_DIC("S"),Y=-1,DLAYGO=0 D IX^DIC:X]"" K DIC,DLAYGO G:Y<0 PUT:X'[U,Q
   10: 	S S=$O(^DIPT(+Y,0))]""
   11: 	I S W $C(7),!,"TEMPLATE ALREADY STORED THERE...." D W:DUZ(0)'="@" G PUT:'$T W " OK TO REPLACE" S %=0 D YN^DICN W ! G PUT:%-1 D PURGE
   12: 	S ^DIPT(+Y,0)=$P(Y,U,2)_U_DT_U_DUZ(0)_U_DK_U_DUZ_U_DUZ(0)_U_DT,^DIPT("F"_DK,$P(Y,U,2),+Y)=1
   13: 	I '$D(DIAX) S ^DIPT("FG",$P(Y,U,2),+Y)="",$P(^DIPT(+Y,0),U,8)=1
   14: 	E  S ^DIPT("EX",$P(Y,U,2),+Y)="",$P(^DIPT(+Y,0),U,8,9)=2_U_DIAXFNO
   15: 	S Y=+Y,%X=""
   16: 	F %=1:1 S %X=$O(^UTILITY("DIFG",$J,%X)) Q:%X=""  S ^DIPT(Y,1,%,0)=^(%X) D FLD
   17: 	S:%-1 ^DIPT(Y,1,0)="^.41^"_(%-1)_U_(%-1)
   18: 	I '$D(DIAX) S ^DIPT(Y,"F",2)="S DIFGT="""_$P(^DIPT(+Y,0),U)_""",DIFGBFN="_DK_" D FG^DIFGB;X"
   19: 	E  S ^DIPT(Y,"F",2)="D ^DIAXU;X"
   20: Q	K ^UTILITY("DIFG",$J),DIFG Q
   21: 	;
   22: PURGE	L +^DIPT(+Y)
   23: 	S %Y=0 F %X=0:0 S %Y=$O(^DIPT(+Y,%Y)) Q:%Y=""  K:%Y'="%D" ^DIPT(+Y,%Y)
   24: 	L -^DIPT(+Y)
   25: 	Q
   26: 	;
   27: W	S %=$P(^DIPT(+Y,0),U,6) F X=1:1:$L(%) I DUZ(0)[$E(%,X) Q
   28: 	Q
   29: 	;
   30: FLD	S %Y=""
   31: 	F S=1:1 S %Y=$O(^UTILITY("DIFG",$J,%X,%Y)) Q:%Y=""  S ^DIPT(Y,1,%,"F",S,0)=^(%Y)
   32: 	S:S-1 ^DIPT(Y,1,%,"F",0)="^.411^"_(S-1)_U_(S-1) Q
   33: 	;
   34: TEM	;
   35: 	S X=$E(X,2,99),DIC="^DIPT(",DIC(0)="SQEM",D=$S($D(DIAX):"EX",1:"FG") S:X["?" D="F"_DK
   36: 	S DIC("S")="I $P(^(0),U,4)="_DK_",$P(^(0),U,8)="_$S($D(DIAX):2,1:1)_$S($D(DIAX):",$P(^(0),U,9)=DIAXFNO",1:"")
   37: 	D IX^DIC S X="" Q:Y<0
   38: EN	;
   39: 	K DIR S DA=+Y
   40: 	S DIR(0)="Y",DIR("A")="WANT TO EDIT '"_$P(Y,U,2)_"' TEMPLATE"
   41: 	D ^DIR K DIR S:'Y!$D(DTOUT) X=U Q:'Y  D DIE I '$D(DA) S DC=0 Q
   42: 	S DC(1)=0,DC(0)=DA K DA D GET
   43: 	S DJ=0,X="" ;D EN^DIFGA,PUT:X'=U
   44: 	Q
   45: GET	S DC(1)=$O(^DIPT(DC(0),1,+DC(1))),DC=0 Q:+DC(1)'=DC(1)
   46: 	S %=^(DC(1),0),X=+% Q:'X  S DC=1
   47: 	I DL>1,$P(%,U,2)'>DL F J=$P(%,U,2):1:DL S DC=DC+1,DC(DC)=""
   48: 	I $D(DIAX),$P(%,U,4)>2 S $P(DC(1),U,3)=$O(^DD(+$P(%,U,9),0,"NM",""))
   49: 	I $P(%,U,5)]"" S DC=DC+1,DC(DC)=$P(%,U,5)
   50: 	F J=0:0 S J=$O(^DIPT(DC(0),1,+DC(1),"F",J)) Q:+J'=J  S %=^(J,0),DIAXZ=$P(%,U,2,9),%=+%,%=$S($D(^DD(X,%,0)):$P(^(0),U),1:%) S:'% DC=DC+1,DC(DC)=%_U_DIAXZ
   51: 	S DC=$S($D(DC(2)):2,1:0)
   52: 	Q
   53: DIE	N DL,DK,DI
   54: 	S DIE="^DIPT(",DR=".01;3;6" D ^DIE K DIE,DR S X=""
   55: 	Q
   56: FG	;Entry from Print template
   57: 	K ^UTILITY($J,"W")
   58: 	S DIFG("FE")=D0,DIFG("FUNC")="L",DIFG("FGR")="^UTILITY(""DIFG"",$J,"
   59: 	I 'DIFGT S DIC="^DIPT(",D="FG",DIC("S")="I $P(^(0),U,4)="_DIFGBFN,DIC(0)="O",X=DIFGT K DIFGBFN D IX^DIC S:+Y DIFGT=+Y I Y'>0 K DIFG,DIFGT G Q
   60: 	I $G(DIAR)=4 S DIFG("FGR")="^DIAR(1.11,DIARC,""D""," I DIARF=DIARF2,$D(^DIC(+DIARF,0,"GL")) S D1=^("GL"),@(D1_"D0,-9)")=DIARC
   61: 	I $G(DIARP)]"",+DIARP'=+DIFGT S DIFGT=DIARP,^DIPT(DIARP,"F",2)="S DIFGT="_DIARP_" D FG^DIFGB;X"
   62: 	N DI,D0 D START^DIFGG
   63: 	I $D(DIARD) S DIARD=DIARD+1 W:(DIARD#50=0) !,DIARD," RECORDS PROCESSED"
   64: 	I $G(DIAR)=4 S ^DIAR(1.11,DIARC,"D",0)="^1.113^"_DILC_U_DILC Q
   65: 	S DIWL=1,DIWR=IOM-1,DIWF="NW"
   66: 	F D1=0:0 S D1=$O(^UTILITY("DIFG",$J,D1)) Q:D1'>0  S X=^(D1,0) D ^DIWP Q:'DN
   67: 	D:DN ^DIWW G Q
   68: WR	F D1=0:0 S D1=$O(^DIAR(1.11,DIARC,"D",D1)) Q:D1'>0  S X=^(D1,0) W X
   69: 	G Q