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