Return to DDS5.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DDS5	;SFISC/MKO-MULTS,NEXT/PREV PAGE,NEXT BLOCK ;10:39 AM  25 Oct 1994
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: 	I X="" D:DDSOLD="" NF^DDS01 D:DDSOLD]"" DM^DDS6 Q
    5: 	I DIR0N,$D(DUZ)#2 S ^DISV(DUZ,$E(DDSGL,1,28))=$E(DDSGL,29,999)_X
    6: 	I $G(@DDSREFS@("ASUB",DDSPG,DDSBK,DDO))]"" S DDS5PG=^(DDO)
    7: 	E  I $P($G(DDSO(7)),U,2)="" D:X=DDSOLD NF^DDS01 Q
    8: 	D MULT,R^DDSR
    9: 	;
   10: 	K DDSSTACK
   11: 	X:$G(^DIST(.404,DDSBK,40,DDO,10))'?."^" ^(10)
   12: 	I $D(DDSSTACK) D ^DDSSTK,R^DDS3 K DDSBR
   13: 	D:$D(DDSBR)#2 BR^DDS2
   14: 	Q
   15: MULT	;
   16: 	N DIE,DDO,DDSBK,DDSDN,DDSNP,DDSOPB,DDSPG,DDSPTB,DDSREP,DDSTP
   17: 	;
   18: 	I $G(DDS5PG) S DDSPG=DDS5PG K DDS5PG
   19: 	E  D
   20: 	. S DDSPG(1)=$P($G(DDSO(7)),U,2) Q:DDSPG(1)=""
   21: 	. S DDSPG=$O(^DIST(.403,+DDS,40,"B",DDSPG(1),"")) Q:DDSPG=""
   22: 	Q:$D(^DIST(.403,+DDS,40,+$G(DDSPG),0))[0
   23: 	N:'$P(^(0),U,6) DDSSC
   24: 	;
   25: 	D DDA(Y,.DA,.DDSDL)
   26: 	I Y'=-1 D
   27: 	. N DDP,DDSDA,DDSFLD,DDSDLORG,DDSDAORG,DDSFLORG
   28: 	. S DIE=U_$P(DDSU("M"),U,2),DDP=$P(DDSU("M"),U,3)
   29: 	. S DDSDLORG=DDSDL,DDSDAORG=DA,DDSDA=DA_","
   30: 	. F DDSI=1:1:DDSDL S DDSDAORG(DDSI)=DA(DDSI),DDSDA=DDSDA_DA(DDSI)_","
   31: 	. K DDSI
   32: 	. S DDSSTK=1
   33: 	. D PROC^DDS
   34: 	D LST(.DA,.DDSDL,DDP,DDSDA,DDSFLD)
   35: 	D UDA(.DA,.DDSDL)
   36: 	Q
   37: 	;
   38: LST(DA,DDSDL,DDP,DDSDA,DDSFLD)	;Save last edited subrecord
   39: 	;In:  DA array, DDSDL      at subfile level
   40: 	;     DDP, DDSDA, DDSFLD   at file level
   41: 	N DDSDIE,Y
   42: 	S DDSDIE=U_$P(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"M"),U,2)
   43: 	I $D(@(DDSDIE_"+$G(DA),0)"))[0 D
   44: 	. S DA=$S($D(@(DDSDIE_"0)"))#2:$P(^(0),U,3),1:$O(^(0)))
   45: 	. I DA>0 D
   46: 	.. N C
   47: 	.. S Y=$P(@(DDSDIE_DA_",0)"),U)
   48: 	.. S C=$P(^DD(+$P(^DD(DDP,DDSFLD,0),U,2),.01,0),U,2)
   49: 	.. D Y^DIQ
   50: 	. E  S (DA,Y)=""
   51: 	E  S (DA,Y)=""
   52: 	I DA>0,$D(DUZ)#2 S ^DISV(DUZ,$E(DDSDIE,1,28))=$E(DDSDIE,29,999)_DA
   53: 	;
   54: 	S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=Y,^("D")=DA,DDACT="N"
   55: 	Q
   56: 	;
   57: SEL	;Issue the read at the Select mult prompt
   58: 	S DIR(0)="PO"_DDSGL_":QEMZ"_$E("L",'$D(DDSTP)&'$P($G(DDSO(4)),U,5))
   59: 	S:$D(@(DDSGL_"0)"))[0 @(DDSGL_"0)")=U_$P(^DD(DDP,+DDSFLD,0),U,2)_U_U
   60: 	D DDA(0,.DA,.DDSDL),^DIR,UDA(.DA,.DDSDL) K DIR,DUOUT,DIRUT,DIROUT
   61: 	Q:DDACT'="N"
   62: 	;
   63: 	I DIR0N S (X,Y)=DDSOLD Q
   64: 	I $P(Y,U,3)=1 S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=+Y_","_DDSDA_DDSGL
   65: 	E  S DIR0N=1
   66: 	S Y=$P(Y,U)
   67: 	S:X="" Y=""
   68: 	Q
   69: 	;
   70: DDA(Y,DA,DL)	;Push Y onto DA array
   71: 	N I
   72: 	F I=DL:-1:1 S DA(I+1)=DA(I)
   73: 	S DA(1)=DA,DL=DL+1
   74: 	S (DA,@("D"_DL))=$S(+$P($G(Y),"E"):+$P(Y,"E"),1:0)
   75: 	Q
   76: 	;
   77: UDA(DA,DL)	;Pop DA array
   78: 	N I
   79: 	S DA=DA(1)
   80: 	F I=2:1:DL S DA(I-1)=DA(I)
   81: 	K DA(DL),@("D"_DL)
   82: 	S DL=DL-1
   83: 	Q
   84: NP(Y)	;Returns: Next page
   85: 	;         (Y=1 if found, 0 if not found)
   86: 	N P,P1
   87: 	S Y=0,P1=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,4)
   88: 	I P1]"" D
   89: 	. S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
   90: 	. I P,P'=DDSPG,$D(^DIST(.403,+DDS,40,P,0))#2 S Y=1
   91: 	Q $S(Y=1:P,1:DDSPG)
   92: PP(Y)	;
   93: 	N P,P1
   94: 	S Y=0,P1=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,5)
   95: 	I P1]"" D
   96: 	. S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
   97: 	. I P,P'=DDSPG,$D(^DIST(.403,+DDS,40,P,0))#2 S Y=1
   98: 	Q $S(Y=1:P,1:DDSPG)
   99: NB(Y)	;
  100: 	N B,BO,X
  101: 	S (B,Y)=0,BO=$P($G(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,0)),U,2)
  102: 	I BO F  D  Q:B=DDSBK!Y
  103: 	. S BO=$O(^DIST(.403,+DDS,40,DDSPG,40,"AC",BO)) S:'BO BO=$O(^("")) S B=$O(^(BO,""))
  104: 	. S X=$G(@DDSREFS@(DDSPG,B))
  105: 	. I $P(X,U)]"",$P(X,U,5)'="h",$P(X,U,9),B'=DDSBK S Y=1
  106: 	Q B