DDS5 ;SFISC/MKO-MULTS,NEXT/PREV PAGE,NEXT BLOCK ;9:53 AM 1 Oct 1999
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
I X="" D:DDSOLD="" NF^DDS01 D:DDSOLD]"" DM^DDS6 Q
I DIR0N,$D(DUZ)#2 S ^DISV(DUZ,$E(DDSGL,1,28))=$E(DDSGL,29,999)_X
I $G(@DDSREFS@("ASUB",DDSPG,DDSBK,DDO))]"" S DDS5PG=^(DDO)
E I $P($G(DDSO(7)),U,2)="" D:X=DDSOLD NF^DDS01 Q
D MULT,R^DDSR
;
K DDSSTACK
X:$G(^DIST(.404,DDSBK,40,DDO,10))'?."^" ^(10)
I $D(DDSSTACK) D ^DDSSTK,R^DDS3 K DDSBR
D:$D(DDSBR)#2 BR^DDS2
Q
MULT ;
N DIE,DDO,DDSBK,DDSDN,DDSNP,DDSOPB,DDSPG,DDSPTB,DDSREP,DDSTP
;
I $G(DDS5PG) S DDSPG=DDS5PG K DDS5PG
E D
. S DDSPG(1)=$P($G(DDSO(7)),U,2) Q:DDSPG(1)=""
. S DDSPG=$O(^DIST(.403,+DDS,40,"B",DDSPG(1),"")) Q:DDSPG=""
Q:$D(^DIST(.403,+DDS,40,+$G(DDSPG),0))[0
N:'$P(^(0),U,6) DDSSC
;
D DDA(Y,.DA,.DDSDL)
I Y'=-1 D
. N DDP,DDSDA,DDSFLD,DDSDLORG,DDSDAORG,DDSFLORG
. S DIE=U_$P(DDSU("M"),U,2),DDP=$P(DDSU("M"),U,3)
. S DDSDLORG=DDSDL,DDSDAORG=DA,DDSDA=DA_","
. F DDSI=1:1:DDSDL S DDSDAORG(DDSI)=DA(DDSI),DDSDA=DDSDA_DA(DDSI)_","
. K DDSI
. S DDSSTK=1
. D PROC^DDS
D LST(.DA,.DDSDL,DDP,DDSDA,DDSFLD)
D UDA(.DA,.DDSDL)
Q
;
LST(DA,DDSDL,DDP,DDSDA,DDSFLD) ;Save last edited subrecord
;In: DA array, DDSDL at subfile level
; DDP, DDSDA, DDSFLD at file level
N DDSDIE,Y
S DDSDIE=U_$P(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"M"),U,2)
I $D(@(DDSDIE_"+$G(DA),0)"))[0 D
. S DA=$S($D(@(DDSDIE_"0)"))#2:$P(^(0),U,3),1:$O(^(0)))
. I DA>0 D
.. N C
.. S Y=$P(@(DDSDIE_DA_",0)"),U)
.. S C=$P(^DD(+$P(^DD(DDP,DDSFLD,0),U,2),.01,0),U,2)
.. D Y^DIQ
. E S (DA,Y)=""
E S (DA,Y)=""
I DA>0,$D(DUZ)#2 S ^DISV(DUZ,$E(DDSDIE,1,28))=$E(DDSDIE,29,999)_DA
;
S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=Y,^("D")=DA,DDACT="N"
Q
;
SEL ;Issue the read at the Select mult prompt
S DIR(0)="PO"_DDSGL_":QEMZ"_$E("L",'$D(DDSTP)&'$P($G(DDSO(4)),U,5))_$E("V",$P($G(DDSO(4)),U,6))
I $D(@(DDSGL_"0)"))[0 S ^(0)=U_$P($G(DDSU("DD")),U,2)_U_U
E I $P(@(DDSGL_"0)"),U,2)'=$P($G(DDSU("DD")),U,2) S $P(^(0),U,2)=$P($G(DDSU("DD")),U,2)
D DDA(0,.DA,.DDSDL) S DDSDA="0,"_DDSDA
D ^DIR K DIR,DUOUT,DIRUT,DIROUT
D UDA(.DA,.DDSDL) S DDSDA=$P(DDSDA,",",2,999)
Q:DDACT'="N"
;
I DIR0N S (X,Y)=DDSOLD Q
I $P(Y,U,3)=1 S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=+Y_","_DDSDA_DDSGL
E S DIR0N=1
S Y=$P(Y,U)
S:X="" Y=""
Q
;
DDA(Y,DA,DL) ;Push Y onto DA array
N I
F I=DL:-1:1 S DA(I+1)=DA(I)
S DA(1)=DA,DL=DL+1
S (DA,@("D"_DL))=$S(+$P($G(Y),"E"):+$P(Y,"E"),1:0)
Q
;
UDA(DA,DL) ;Pop DA array
N I
S DA=DA(1)
F I=2:1:DL S DA(I-1)=DA(I)
K DA(DL),@("D"_DL)
S DL=DL-1
Q
NP(Y) ;Returns: Next page
; (Y=1 if found, 0 if not found)
N P,P1
S Y=0,P1=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,4)
I P1]"" D
. S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
. I P,P'=DDSPG,$D(^DIST(.403,+DDS,40,P,0))#2 S Y=1
Q $S(Y=1:P,1:DDSPG)
PP(Y) ;
N P,P1
S Y=0,P1=$P($G(^DIST(.403,+DDS,40,DDSPG,0)),U,5)
I P1]"" D
. S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
. I P,P'=DDSPG,$D(^DIST(.403,+DDS,40,P,0))#2 S Y=1
Q $S(Y=1:P,1:DDSPG)
NB(Y) ;
N B,BO,X
S (B,Y)=0,BO=$P($G(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,0)),U,2)
I BO F D Q:B=DDSBK!Y
. S BO=$O(^DIST(.403,+DDS,40,DDSPG,40,"AC",BO)) S:'BO BO=$O(^("")) S B=$O(^(BO,""))
. S X=$G(@DDSREFS@(DDSPG,B))
. I $P(X,U)]"",$P(X,U,5)'="h",$P(X,U,9),B'=DDSBK S Y=1
Q B
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDS5 3656 printed Apr 09, 2024@21:48:55 Page 2
DDS5 ;SFISC/MKO-MULTS,NEXT/PREV PAGE,NEXT BLOCK ;9:53 AM 1 Oct 1999
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 IF X=""
if DDSOLD=""
DO NF^DDS01
if DDSOLD]""
DO DM^DDS6
QUIT
+8 IF DIR0N
IF $DATA(DUZ)#2
SET ^DISV(DUZ,$EXTRACT(DDSGL,1,28))=$EXTRACT(DDSGL,29,999)_X
+9 IF $GET(@DDSREFS@("ASUB",DDSPG,DDSBK,DDO))]""
SET DDS5PG=^(DDO)
+10 IF '$TEST
IF $PIECE($GET(DDSO(7)),U,2)=""
if X=DDSOLD
DO NF^DDS01
QUIT
+11 DO MULT
DO R^DDSR
+12 ;
+13 KILL DDSSTACK
+14 if $GET(^DIST(.404,DDSBK,40,DDO,10))'?."^"
XECUTE ^(10)
+15 IF $DATA(DDSSTACK)
DO ^DDSSTK
DO R^DDS3
KILL DDSBR
+16 if $DATA(DDSBR)#2
DO BR^DDS2
+17 QUIT
MULT ;
+1 NEW DIE,DDO,DDSBK,DDSDN,DDSNP,DDSOPB,DDSPG,DDSPTB,DDSREP,DDSTP
+2 ;
+3 IF $GET(DDS5PG)
SET DDSPG=DDS5PG
KILL DDS5PG
+4 IF '$TEST
Begin DoDot:1
+5 SET DDSPG(1)=$PIECE($GET(DDSO(7)),U,2)
if DDSPG(1)=""
QUIT
+6 SET DDSPG=$ORDER(^DIST(.403,+DDS,40,"B",DDSPG(1),""))
if DDSPG=""
QUIT
End DoDot:1
+7 if $DATA(^DIST(.403,+DDS,40,+$GET(DDSPG),0))[0
QUIT
+8 if '$PIECE(^(0),U,6)
NEW DDSSC
+9 ;
+10 DO DDA(Y,.DA,.DDSDL)
+11 IF Y'=-1
Begin DoDot:1
+12 NEW DDP,DDSDA,DDSFLD,DDSDLORG,DDSDAORG,DDSFLORG
+13 SET DIE=U_$PIECE(DDSU("M"),U,2)
SET DDP=$PIECE(DDSU("M"),U,3)
+14 SET DDSDLORG=DDSDL
SET DDSDAORG=DA
SET DDSDA=DA_","
+15 FOR DDSI=1:1:DDSDL
SET DDSDAORG(DDSI)=DA(DDSI)
SET DDSDA=DDSDA_DA(DDSI)_","
+16 KILL DDSI
+17 SET DDSSTK=1
+18 DO PROC^DDS
End DoDot:1
+19 DO LST(.DA,.DDSDL,DDP,DDSDA,DDSFLD)
+20 DO UDA(.DA,.DDSDL)
+21 QUIT
+22 ;
LST(DA,DDSDL,DDP,DDSDA,DDSFLD) ;Save last edited subrecord
+1 ;In: DA array, DDSDL at subfile level
+2 ; DDP, DDSDA, DDSFLD at file level
+3 NEW DDSDIE,Y
+4 SET DDSDIE=U_$PIECE(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"M"),U,2)
+5 IF $DATA(@(DDSDIE_"+$G(DA),0)"))[0
Begin DoDot:1
+6 SET DA=$SELECT($DATA(@(DDSDIE_"0)"))#2:$PIECE(^(0),U,3),1:$ORDER(^(0)))
+7 IF DA>0
Begin DoDot:2
+8 NEW C
+9 SET Y=$PIECE(@(DDSDIE_DA_",0)"),U)
+10 SET C=$PIECE(^DD(+$PIECE(^DD(DDP,DDSFLD,0),U,2),.01,0),U,2)
+11 DO Y^DIQ
End DoDot:2
+12 IF '$TEST
SET (DA,Y)=""
End DoDot:1
+13 IF '$TEST
SET (DA,Y)=""
+14 IF DA>0
IF $DATA(DUZ)#2
SET ^DISV(DUZ,$EXTRACT(DDSDIE,1,28))=$EXTRACT(DDSDIE,29,999)_DA
+15 ;
+16 SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=Y
SET ^("D")=DA
SET DDACT="N"
+17 QUIT
+18 ;
SEL ;Issue the read at the Select mult prompt
+1 SET DIR(0)="PO"_DDSGL_":QEMZ"_$EXTRACT("L",'$DATA(DDSTP)&'$PIECE($GET(DDSO(4)),U,5))_$EXTRACT("V",$PIECE($GET(DDSO(4)),U,6))
+2 IF $DATA(@(DDSGL_"0)"))[0
SET ^(0)=U_$PIECE($GET(DDSU("DD")),U,2)_U_U
+3 IF '$TEST
IF $PIECE(@(DDSGL_"0)"),U,2)'=$PIECE($GET(DDSU("DD")),U,2)
SET $PIECE(^(0),U,2)=$PIECE($GET(DDSU("DD")),U,2)
+4 DO DDA(0,.DA,.DDSDL)
SET DDSDA="0,"_DDSDA
+5 DO ^DIR
KILL DIR,DUOUT,DIRUT,DIROUT
+6 DO UDA(.DA,.DDSDL)
SET DDSDA=$PIECE(DDSDA,",",2,999)
+7 if DDACT'="N"
QUIT
+8 ;
+9 IF DIR0N
SET (X,Y)=DDSOLD
QUIT
+10 IF $PIECE(Y,U,3)=1
SET ^("ADD")=$GET(@DDSREFT@("ADD"))+1
SET ^("ADD",^("ADD"))=+Y_","_DDSDA_DDSGL
+11 IF '$TEST
SET DIR0N=1
+12 SET Y=$PIECE(Y,U)
+13 if X=""
SET Y=""
+14 QUIT
+15 ;
DDA(Y,DA,DL) ;Push Y onto DA array
+1 NEW I
+2 FOR I=DL:-1:1
SET DA(I+1)=DA(I)
+3 SET DA(1)=DA
SET DL=DL+1
+4 SET (DA,@("D"_DL))=$SELECT(+$PIECE($GET(Y),"E"):+$PIECE(Y,"E"),1:0)
+5 QUIT
+6 ;
UDA(DA,DL) ;Pop DA array
+1 NEW I
+2 SET DA=DA(1)
+3 FOR I=2:1:DL
SET DA(I-1)=DA(I)
+4 KILL DA(DL),@("D"_DL)
+5 SET DL=DL-1
+6 QUIT
NP(Y) ;Returns: Next page
+1 ; (Y=1 if found, 0 if not found)
+2 NEW P,P1
+3 SET Y=0
SET P1=$PIECE($GET(^DIST(.403,+DDS,40,DDSPG,0)),U,4)
+4 IF P1]""
Begin DoDot:1
+5 SET P=$ORDER(^DIST(.403,+DDS,40,"B",P1,""))
+6 IF P
IF P'=DDSPG
IF $DATA(^DIST(.403,+DDS,40,P,0))#2
SET Y=1
End DoDot:1
+7 QUIT $SELECT(Y=1:P,1:DDSPG)
PP(Y) ;
+1 NEW P,P1
+2 SET Y=0
SET P1=$PIECE($GET(^DIST(.403,+DDS,40,DDSPG,0)),U,5)
+3 IF P1]""
Begin DoDot:1
+4 SET P=$ORDER(^DIST(.403,+DDS,40,"B",P1,""))
+5 IF P
IF P'=DDSPG
IF $DATA(^DIST(.403,+DDS,40,P,0))#2
SET Y=1
End DoDot:1
+6 QUIT $SELECT(Y=1:P,1:DDSPG)
NB(Y) ;
+1 NEW B,BO,X
+2 SET (B,Y)=0
SET BO=$PIECE($GET(^DIST(.403,+DDS,40,DDSPG,40,DDSBK,0)),U,2)
+3 IF BO
FOR
Begin DoDot:1
+4 SET BO=$ORDER(^DIST(.403,+DDS,40,DDSPG,40,"AC",BO))
if 'BO
SET BO=$ORDER(^(""))
SET B=$ORDER(^(BO,""))
+5 SET X=$GET(@DDSREFS@(DDSPG,B))
+6 IF $PIECE(X,U)]""
IF $PIECE(X,U,5)'="h"
IF $PIECE(X,U,9)
IF B'=DDSBK
SET Y=1
End DoDot:1
if B=DDSBK!Y
QUIT
+7 QUIT B
