DDSZ3.m

DDSZ3 ;SFISC/MKO-FORM COMPILER ;02:49 PM  30 Dec 1993

 ;;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.

 ;

ASUB(DDSPG,DDSFRM) ;

 ;Set @DDSREFS@("ASUB",pg,bk,ddo)=subpage for parent field

 N MF,MB,MP

 S MF=$P(^DIST(.403,+DDSFRM,40,DDSPG,1),U,2) Q:MF=""

 S MP=$P(MF,",",3),MB=$P(MF,",",2),MF=$P(MF,",")

 ;

 S MF=$$GETFLD^DDSLIB(MF,MB,MP,DDSFRM)

 I $G(DIERR) K DIERR,^TMP("DIERR",$J) Q

 S @DDSREFS@("ASUB",$P(MF,",",3),$P(MF,",",2),$P(MF,","))=DDSPG

 Q

 ;

PGRP(FRM,G) ;Find page groups

 ;In:  FRM = Form number

 ;Out: G   = Array of page groups

 ;

 N B,I,NP,P,PP,PG

 S G=0

 S P=0 F  S P=$O(^DIST(.403,FRM,40,P)) Q:'P  D

 . Q:'$D(^DIST(.403,FRM,40,P,0))  S NP=$P(^(0),U,4),PP=$P(^(0),U,5)

 . F PG="NP","PP" I @PG D

 .. S @PG=$O(^DIST(.403,FRM,40,"B",@PG,"")) Q:'@PG

 .. S:$D(^DIST(.403,FRM,40,@PG,0))[0 @PG=""

 . S:NP=P NP=0 S:PP=NP!(PP=P) PP=0

 . S I=0 F  S I=$O(G(I)) Q:'I  Q:U_G(I)_U[(U_P_U)

 . I 'I S G=G+1,G(G)=P_$S(NP:U_NP,1:"")_$S(PP:U_PP,1:"") Q

 . F PG="NP","PP" I @PG,U_G(I)_U'[(U_@PG_U) S G(I)=G(I)_U_@PG

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DDSZ3   1300     printed  Apr 09, 2024@21:53:30                                                                                                                                                                                                       Page 2

DDSZ3     ;SFISC/MKO-FORM COMPILER ;02:49 PM  30 Dec 1993

 +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       ;

ASUB(DDSPG,DDSFRM) ;

 +1       ;Set @DDSREFS@("ASUB",pg,bk,ddo)=subpage for parent field

 +2        NEW MF,MB,MP

 +3        SET MF=$PIECE(^DIST(.403,+DDSFRM,40,DDSPG,1),U,2)

           if MF=""

               QUIT 

 +4        SET MP=$PIECE(MF,",",3)

           SET MB=$PIECE(MF,",",2)

           SET MF=$PIECE(MF,",")

 +5       ;

 +6        SET MF=$$GETFLD^DDSLIB(MF,MB,MP,DDSFRM)

 +7        IF $GET(DIERR)

               KILL DIERR,^TMP("DIERR",$JOB)

               QUIT 

 +8        SET @DDSREFS@("ASUB",$PIECE(MF,",",3),$PIECE(MF,",",2),$PIECE(MF,","))=DDSPG

 +9        QUIT 

 +10      ;

PGRP(FRM,G) ;Find page groups

 +1       ;In:  FRM = Form number

 +2       ;Out: G   = Array of page groups

 +3       ;

 +4        NEW B,I,NP,P,PP,PG

 +5        SET G=0

 +6        SET P=0

           FOR 

               SET P=$ORDER(^DIST(.403,FRM,40,P))

               if 'P

                   QUIT 

               Begin DoDot:1

 +7                if '$DATA(^DIST(.403,FRM,40,P,0))

                       QUIT 

                   SET NP=$PIECE(^(0),U,4)

                   SET PP=$PIECE(^(0),U,5)

 +8                FOR PG="NP","PP"

                       IF @PG

                           Begin DoDot:2

 +9                            SET @PG=$ORDER(^DIST(.403,FRM,40,"B",@PG,""))

                               if '@PG

                                   QUIT 

 +10                           if $DATA(^DIST(.403,FRM,40,@PG,0))[0

                                   SET @PG=""

                           End DoDot:2

 +11               if NP=P

                       SET NP=0

                   if PP=NP!(PP=P)

                       SET PP=0

 +12               SET I=0

                   FOR 

                       SET I=$ORDER(G(I))

                       if 'I

                           QUIT 

                       if U_G(I)_U[(U_P_U)

                           QUIT 

 +13               IF 'I

                       SET G=G+1

                       SET G(G)=P_$SELECT(NP:U_NP,1:"")_$SELECT(PP:U_PP,1:"")

                       QUIT 

 +14               FOR PG="NP","PP"

                       IF @PG

                           IF U_G(I)_U'[(U_@PG_U)

                               SET G(I)=G(I)_U_@PG

               End DoDot:1

 +15       QUIT