BMCADD2.m

BMCADD2 ; IHS/PHXAO/TMJ - display routine referrals ;

 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 ;; ;

EN ; -- main entry point for BMC GENRET SELECTION ITEMS

 K BMCCSEL,BMCRR

 D EN^VALM("BMC ROUTINE REFERRAL LIST")

 D CLEAR^VALM1

 K BMCDISP,BMCSEL,BMCLIST,C,X,I,K,J,BMCHIGH,BMCCUT,BMCCSEL,BMCCNTL

 K VALMHDR,VALMCNT

 Q

 ;

HDR ; -- header code

 S VALMHDR(1)="Locally defined routine referral template selection"

 S VALMSG="  +  next screen  - previous screen   ?? help"

 Q

 ;

INIT ; -- init variables and list array

 K BMCDISP,BMCSEL,BMCHIGH,BMCLIST

 S BMCHIGH=0,X=0 F  S X=$O(^BMCRTNRF("B",X)) Q:X=""  S Y=$O(^BMCRTNRF("B",X,0)),BMCHIGH=BMCHIGH+1,BMCSEL(BMCHIGH)=Y

 S BMCCUT=BMCHIGH/2 S:BMCCUT'=(BMCCUT\1) BMCCUT=(BMCCUT\1)+1

 S (C,I)=0,J=1,K=1 F  S I=$O(BMCSEL(I)) Q:I'=+I!($D(BMCDISP(I)))  D

 .S C=C+1,BMCLIST(C,0)=I_") "_$P(^BMCRTNRF(BMCSEL(I),0),U) S BMCDISP(I)="",BMCLIST("IDX",C,C)=""

 .S J=I+BMCCUT I $D(BMCSEL(J)),'$D(BMCDISP(J)) S $E(BMCLIST(C,0),40)=J_") "_$P(^BMCRTNRF(BMCSEL(J),0),U) S BMCDISP(J)=""

 K BMCDISP

 S VALMCNT=C

 Q

 ;

HELP ; -- help code

 D FULL^VALM1

 W:$D(IOF) @IOF

 W !,"Enter an S to Select a Routine Referral Template, Q to Quit",!

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

 S DIR(0)="EO",DIR("A")="Hit return to continue..." K DA D ^DIR K DIR

 D BACK

 Q

 ;

SELECT ;EP - called from protocol

 S DIR(0)="N^1:"_BMCHIGH_":",DIR("A")="Which Routine Referral Template" K DA D ^DIR K DIR

 I $D(DIRUT) W !,"No items selected." K BMCRR Q

 S BMCRR=+BMCSEL(+Y)

 Q

BACK ;go back to listman

 D TERM^VALM0

 S VALMBCK="R"

 D INIT

 D HDR

 K DIR

 K X,Y,Z,I

 Q

EXIT ; -- exit code

 K BMCDISP

 K VALMCC,VALMHDR

 Q

 ;

EXPND ; -- expand code

 Q

 ;

BMCADD2   ; IHS/PHXAO/TMJ - display routine referrals ;

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 +2       ;; ;

EN        ; -- main entry point for BMC GENRET SELECTION ITEMS

 +1        KILL BMCCSEL,BMCRR

 +2        DO EN^VALM("BMC ROUTINE REFERRAL LIST")

 +3        DO CLEAR^VALM1

 +4        KILL BMCDISP,BMCSEL,BMCLIST,C,X,I,K,J,BMCHIGH,BMCCUT,BMCCSEL,BMCCNTL

 +5        KILL VALMHDR,VALMCNT

 +6        QUIT 

 +7       ;

HDR       ; -- header code

 +1        SET VALMHDR(1)="Locally defined routine referral template selection"

 +2        SET VALMSG="  +  next screen  - previous screen   ?? help"

 +3        QUIT 

 +4       ;

INIT      ; -- init variables and list array

 +1        KILL BMCDISP,BMCSEL,BMCHIGH,BMCLIST

 +2        SET BMCHIGH=0

           SET X=0

           FOR 

               SET X=$ORDER(^BMCRTNRF("B",X))

               IF X=""

                   QUIT 

               SET Y=$ORDER(^BMCRTNRF("B",X,0))

               SET BMCHIGH=BMCHIGH+1

               SET BMCSEL(BMCHIGH)=Y

 +3        SET BMCCUT=BMCHIGH/2

           IF BMCCUT'=(BMCCUT\1)

               SET BMCCUT=(BMCCUT\1)+1

 +4        SET (C,I)=0

           SET J=1

           SET K=1

           FOR 

               SET I=$ORDER(BMCSEL(I))

               IF I'=+I!($DATA(BMCDISP(I)))

                   QUIT 

               Begin DoDot:1

 +5                SET C=C+1

                   SET BMCLIST(C,0)=I_") "_$PIECE(^BMCRTNRF(BMCSEL(I),0),U)

                   SET BMCDISP(I)=""

                   SET BMCLIST("IDX",C,C)=""

 +6                SET J=I+BMCCUT

                   IF $DATA(BMCSEL(J))

                       IF '$DATA(BMCDISP(J))

                           SET $EXTRACT(BMCLIST(C,0),40)=J_") "_$PIECE(^BMCRTNRF(BMCSEL(J),0),U)

                           SET BMCDISP(J)=""

               End DoDot:1

 +7        KILL BMCDISP

 +8        SET VALMCNT=C

 +9        QUIT 

 +10      ;

HELP      ; -- help code

 +1        DO FULL^VALM1

 +2        IF $DATA(IOF)

               WRITE @IOF

 +3        WRITE !,"Enter an S to Select a Routine Referral Template, Q to Quit",!

 +4        SET X="?"

           DO DISP^XQORM1

           WRITE !

 +5        SET DIR(0)="EO"

           SET DIR("A")="Hit return to continue..."

           KILL DA

           DO ^DIR

           KILL DIR

 +6        DO BACK

 +7        QUIT 

 +8       ;

SELECT    ;EP - called from protocol

 +1        SET DIR(0)="N^1:"_BMCHIGH_":"

           SET DIR("A")="Which Routine Referral Template"

           KILL DA

           DO ^DIR

           KILL DIR

 +2        IF $DATA(DIRUT)

               WRITE !,"No items selected."

               KILL BMCRR

               QUIT 

 +3        SET BMCRR=+BMCSEL(+Y)

 +4        QUIT 

BACK      ;go back to listman

 +1        DO TERM^VALM0

 +2        SET VALMBCK="R"

 +3        DO INIT

 +4        DO HDR

 +5        KILL DIR

 +6        KILL X,Y,Z,I

 +7        QUIT 

EXIT      ; -- exit code

 +1        KILL BMCDISP

 +2        KILL VALMCC,VALMHDR

 +3        QUIT 

 +4       ;

EXPND     ; -- expand code

 +1        QUIT 

 +2       ;