BDGSYS6.m

BDGSYS6 ; IHS/ANMC/LJF - MAIL GROUPS ON BULLETINS ; 

 ;;5.3;PIMS;;APR 26, 2002

 ;

EN ; -- main entry point for BDG SYS BULLETIN

 NEW VALMCNT

 D TERM^VALM0,CLEAR^VALM1

 D EN^VALM("BDG SYS BULLETIN")

 D CLEAR^VALM1

 Q

 ;

HDR ; -- header code

 NEW X

 S X=$$GET1^DIQ(40.8,BDGDIV,.01)

 S VALMHDR(1)=$$SP(79-$L(X)\2)_X

 Q

 ;

INIT ; -- init variables and list array

 NEW NAME,IEN,COUNT,LINE,IEN2

 S VALMCNT=0

 K ^TMP("BDGSYS6",$J)

 S NAME="BDG"

 F  S NAME=$O(^XMB(3.6,"B",NAME)) Q:NAME=""  Q:$E(NAME,1,3)'="BDG"  D

 . S IEN=0

 . F  S IEN=$O(^XMB(3.6,"B",NAME,IEN)) Q:'IEN  D

 .. S COUNT=$G(COUNT)+1

 .. S LINE=$J(COUNT,2)_". "_$$GET1^DIQ(3.6,IEN,.01)      ;bulletin name

 .. S IEN2=$O(^XMB(3.6,IEN,2,0)) I IEN2 D

 ... S LINE=$$PAD(LINE,32)_$$GET1^DIQ(3.62,IEN2_","_IEN,.01)  ;mail grp

 .. D SET(LINE,COUNT,IEN,.VALMCNT)

 .. ;

 .. ; print more lines if >1 mail group on bulletin

 .. Q:'IEN2  F  S IEN2=$O(^XMB(3.6,IEN,2,IEN2)) Q:'IEN2  D

 ... S LINE=$$SP(32)_$$GET1^DIQ(3.62,IEN2_","_IEN,.01)

 ... D SET(LINE,COUNT,IEN,.VALMCNT)

 ;

 I '$D(^TMP("BDGSYS6",$J)) D

 . D SET("*** NO ADT BULLETINS FOUND!! ***",0,0,.VALMCNT)

 Q

 ;

SET(DATA,NUM,N,LINE) ; put display line into array

 S LINE=LINE+1

 S ^TMP("BDGSYS6",$J,LINE,0)=DATA

 S ^TMP("BDGSYS6",$J,"IDX",LINE,NUM)=N

 Q

 ;

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !!

 Q

 ;

EXIT ; -- exit code

 K ^TMP("BDGSYS6",$J)

 Q

 ;

EXPND ; -- expand code

 Q

 ;

RESET ; -- update partition for return to list manager

 I $D(VALMQUIT) S VALMBCK="Q" Q

 D TERM^VALM0 S VALMBCK="R"

 D INIT,HDR

 Q

 ;

EDIT ;EP; called by Edit Entry protocol

 NEW X,Y,Z,BDGN,DIE,DA,DR,DLAYGO

 D FULL^VALM1

 D EN^VALM2(XQORNOD(0),"OS")

 I '$D(VALMY) Q

 S X=0 F  S X=$O(VALMY(X)) Q:X=""  D

 . S Y=0 F  S Y=$O(^TMP("BDGSYS6",$J,"IDX",Y)) Q:Y=""  D

 .. S Z=$O(^TMP("BDGSYS6",$J,"IDX",Y,0))

 .. Q:^TMP("BDGSYS6",$J,"IDX",Y,Z)=""

 .. I Z=X S BDGN=^TMP("BDGSYS6",$J,"IDX",Y,Z)

 ;

 I 'BDGN D RESET Q

 W !,"BULLETIN: ",$$GET1^DIQ(3.6,BDGN,.01),!

 S DIE=3.6,DA=BDGN,DR=4 D ^DIE

 D RESET

 Q

 ;

PAD(D,L) ;EP -- SUBRTN to pad length of data

 ; -- D=data L=length

 Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)

 ;

SP(N) ; -- SUBRTN to pad N number of spaces

 Q $$PAD(" ",N)

 ;

BDGSYS6   ; IHS/ANMC/LJF - MAIL GROUPS ON BULLETINS ; 

 +1       ;;5.3;PIMS;;APR 26, 2002

 +2       ;

EN        ; -- main entry point for BDG SYS BULLETIN

 +1        NEW VALMCNT

 +2        DO TERM^VALM0

           DO CLEAR^VALM1

 +3        DO EN^VALM("BDG SYS BULLETIN")

 +4        DO CLEAR^VALM1

 +5        QUIT 

 +6       ;

HDR       ; -- header code

 +1        NEW X

 +2        SET X=$$GET1^DIQ(40.8,BDGDIV,.01)

 +3        SET VALMHDR(1)=$$SP(79-$LENGTH(X)\2)_X

 +4        QUIT 

 +5       ;

INIT      ; -- init variables and list array

 +1        NEW NAME,IEN,COUNT,LINE,IEN2

 +2        SET VALMCNT=0

 +3        KILL ^TMP("BDGSYS6",$JOB)

 +4        SET NAME="BDG"

 +5        FOR 

               SET NAME=$ORDER(^XMB(3.6,"B",NAME))

               IF NAME=""

                   QUIT 

               IF $EXTRACT(NAME,1,3)'="BDG"

                   QUIT 

               Begin DoDot:1

 +6                SET IEN=0

 +7                FOR 

                       SET IEN=$ORDER(^XMB(3.6,"B",NAME,IEN))

                       IF 'IEN

                           QUIT 

                       Begin DoDot:2

 +8                        SET COUNT=$GET(COUNT)+1

 +9       ;bulletin name

                           SET LINE=$JUSTIFY(COUNT,2)_". "_$$GET1^DIQ(3.6,IEN,.01)

 +10                       SET IEN2=$ORDER(^XMB(3.6,IEN,2,0))

                           IF IEN2

                               Begin DoDot:3

 +11      ;mail grp

                                   SET LINE=$$PAD(LINE,32)_$$GET1^DIQ(3.62,IEN2_","_IEN,.01)

                               End DoDot:3

 +12                       DO SET(LINE,COUNT,IEN,.VALMCNT)

 +13      ;

 +14      ; print more lines if >1 mail group on bulletin

 +15                       IF 'IEN2

                               QUIT 

                           FOR 

                               SET IEN2=$ORDER(^XMB(3.6,IEN,2,IEN2))

                               IF 'IEN2

                                   QUIT 

                               Begin DoDot:3

 +16                               SET LINE=$$SP(32)_$$GET1^DIQ(3.62,IEN2_","_IEN,.01)

 +17                               DO SET(LINE,COUNT,IEN,.VALMCNT)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +18      ;

 +19       IF '$DATA(^TMP("BDGSYS6",$JOB))

               Begin DoDot:1

 +20               DO SET("*** NO ADT BULLETINS FOUND!! ***",0,0,.VALMCNT)

               End DoDot:1

 +21       QUIT 

 +22      ;

SET(DATA,NUM,N,LINE) ; put display line into array

 +1        SET LINE=LINE+1

 +2        SET ^TMP("BDGSYS6",$JOB,LINE,0)=DATA

 +3        SET ^TMP("BDGSYS6",$JOB,"IDX",LINE,NUM)=N

 +4        QUIT 

 +5       ;

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT 

 +3       ;

EXIT      ; -- exit code

 +1        KILL ^TMP("BDGSYS6",$JOB)

 +2        QUIT 

 +3       ;

EXPND     ; -- expand code

 +1        QUIT 

 +2       ;

RESET     ; -- update partition for return to list manager

 +1        IF $DATA(VALMQUIT)

               SET VALMBCK="Q"

               QUIT 

 +2        DO TERM^VALM0

           SET VALMBCK="R"

 +3        DO INIT

           DO HDR

 +4        QUIT 

 +5       ;

EDIT      ;EP; called by Edit Entry protocol

 +1        NEW X,Y,Z,BDGN,DIE,DA,DR,DLAYGO

 +2        DO FULL^VALM1

 +3        DO EN^VALM2(XQORNOD(0),"OS")

 +4        IF '$DATA(VALMY)

               QUIT 

 +5        SET X=0

           FOR 

               SET X=$ORDER(VALMY(X))

               IF X=""

                   QUIT 

               Begin DoDot:1

 +6                SET Y=0

                   FOR 

                       SET Y=$ORDER(^TMP("BDGSYS6",$JOB,"IDX",Y))

                       IF Y=""

                           QUIT 

                       Begin DoDot:2

 +7                        SET Z=$ORDER(^TMP("BDGSYS6",$JOB,"IDX",Y,0))

 +8                        IF ^TMP("BDGSYS6",$JOB,"IDX",Y,Z)=""

                               QUIT 

 +9                        IF Z=X

                               SET BDGN=^TMP("BDGSYS6",$JOB,"IDX",Y,Z)

                       End DoDot:2

               End DoDot:1

 +10      ;

 +11       IF 'BDGN

               DO RESET

               QUIT 

 +12       WRITE !,"BULLETIN: ",$$GET1^DIQ(3.6,BDGN,.01),!

 +13       SET DIE=3.6

           SET DA=BDGN

           SET DR=4

           DO ^DIE

 +14       DO RESET

 +15       QUIT 

 +16      ;

PAD(D,L)  ;EP -- SUBRTN to pad length of data

 +1       ; -- D=data L=length

 +2        QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)

 +3       ;

SP(N)     ; -- SUBRTN to pad N number of spaces

 +1        QUIT $$PAD(" ",N)

 +2       ;