- BDGSYS7 ; IHS/ANMC/LJF - TRANSFER FACILITY SETUP ; [ 07/31/2003 1:14 PM ]
- ;;5.3;PIMS;;APR 26, 2002
- ;
- EN ; -- main entry point for BDG SYS TRANSFER FAC
- NEW VALMCNT
- D TERM^VALM0,CLEAR^VALM1
- D EN^VALM("BDG SYS TRANSFER FAC")
- 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,Y
- S VALMCNT=0
- K ^TMP("BDGSYS7",$J)
- S NAME=0
- F S NAME=$O(^AUTTTFAC("B",NAME)) Q:NAME="" D
- . S IEN=0
- . F S IEN=$O(^AUTTTFAC("B",NAME,IEN)) Q:'IEN D
- .. S COUNT=$G(COUNT)+1
- .. S LINE=$J(COUNT,2)_". "_$$GET1^DIQ(9999999.91,IEN,.01) ;serv name
- .. S LINE=$$PAD(LINE,40)_$$GET1^DIQ(9999999.91,IEN,.02) ;inactive dt
- .. S LINE=$$PAD(LINE,59)_$$GET1^DIQ(9999999.91,IEN,.03) ;IHS link
- .. D SET(LINE,COUNT,IEN,.VALMCNT)
- ;
- I '$D(^TMP("BDGSYS7",$J)) D
- . D SET("*** NO ENTRIES FOUND ***",0,0,.VALMCNT)
- Q
- ;
- SET(DATA,NUM,N,LINE) ; put display line into array
- S LINE=LINE+1
- S ^TMP("BDGSYS7",$J,LINE,0)=DATA
- S ^TMP("BDGSYS7",$J,"IDX",LINE,NUM)=N
- Q
- ;
- HELP ; -- help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- EXIT ; -- exit code
- K ^TMP("BDGSYS7",$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,DDSFILE,DA,DR
- 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("BDGSYS7",$J,"IDX",Y)) Q:Y="" D
- .. S Z=$O(^TMP("BDGSYS7",$J,"IDX",Y,0))
- .. Q:^TMP("BDGSYS7",$J,"IDX",Y,Z)=""
- .. I Z=X S BDGN=^TMP("BDGSYS7",$J,"IDX",Y,Z)
- ;
- I 'BDGN D RESET Q
- S DIE=9999999.91,DR=".01:.03",DA=BDGN D ^DIE
- D RESET
- Q
- ;
- ADD ;EP; called by Add Entry protocol
- NEW DIC,DLAYGO,Y,DDSFILE,DA,DR
- D FULL^VALM1
- S (DIC,DLAYGO)=9999999.91,DIC(0)="AEMQZL" D ^DIC I Y<1 D RESET Q
- ;IHS/ITSC/WAR 7/31/03 BDGN is undefined coming from protocal ien 1519
- I '$DATA(BDGN) S BDGN=+Y ;Need to look at this more in the future
- S DIE=9999999.91,DR=".01:.03",DA=BDGN 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)
- BDGSYS7 ; IHS/ANMC/LJF - TRANSFER FACILITY SETUP ; [ 07/31/2003 1:14 PM ]
- +1 ;;5.3;PIMS;;APR 26, 2002
- +2 ;
- EN ; -- main entry point for BDG SYS TRANSFER FAC
- +1 NEW VALMCNT
- +2 DO TERM^VALM0
- DO CLEAR^VALM1
- +3 DO EN^VALM("BDG SYS TRANSFER FAC")
- +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,Y
- +2 SET VALMCNT=0
- +3 KILL ^TMP("BDGSYS7",$JOB)
- +4 SET NAME=0
- +5 FOR
- SET NAME=$ORDER(^AUTTTFAC("B",NAME))
- IF NAME=""
- QUIT
- Begin DoDot:1
- +6 SET IEN=0
- +7 FOR
- SET IEN=$ORDER(^AUTTTFAC("B",NAME,IEN))
- IF 'IEN
- QUIT
- Begin DoDot:2
- +8 SET COUNT=$GET(COUNT)+1
- +9 ;serv name
- SET LINE=$JUSTIFY(COUNT,2)_". "_$$GET1^DIQ(9999999.91,IEN,.01)
- +10 ;inactive dt
- SET LINE=$$PAD(LINE,40)_$$GET1^DIQ(9999999.91,IEN,.02)
- +11 ;IHS link
- SET LINE=$$PAD(LINE,59)_$$GET1^DIQ(9999999.91,IEN,.03)
- +12 DO SET(LINE,COUNT,IEN,.VALMCNT)
- End DoDot:2
- End DoDot:1
- +13 ;
- +14 IF '$DATA(^TMP("BDGSYS7",$JOB))
- Begin DoDot:1
- +15 DO SET("*** NO ENTRIES FOUND ***",0,0,.VALMCNT)
- End DoDot:1
- +16 QUIT
- +17 ;
- SET(DATA,NUM,N,LINE) ; put display line into array
- +1 SET LINE=LINE+1
- +2 SET ^TMP("BDGSYS7",$JOB,LINE,0)=DATA
- +3 SET ^TMP("BDGSYS7",$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("BDGSYS7",$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,DDSFILE,DA,DR
- +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("BDGSYS7",$JOB,"IDX",Y))
- IF Y=""
- QUIT
- Begin DoDot:2
- +7 SET Z=$ORDER(^TMP("BDGSYS7",$JOB,"IDX",Y,0))
- +8 IF ^TMP("BDGSYS7",$JOB,"IDX",Y,Z)=""
- QUIT
- +9 IF Z=X
- SET BDGN=^TMP("BDGSYS7",$JOB,"IDX",Y,Z)
- End DoDot:2
- End DoDot:1
- +10 ;
- +11 IF 'BDGN
- DO RESET
- QUIT
- +12 SET DIE=9999999.91
- SET DR=".01:.03"
- SET DA=BDGN
- DO ^DIE
- +13 DO RESET
- +14 QUIT
- +15 ;
- ADD ;EP; called by Add Entry protocol
- +1 NEW DIC,DLAYGO,Y,DDSFILE,DA,DR
- +2 DO FULL^VALM1
- +3 SET (DIC,DLAYGO)=9999999.91
- SET DIC(0)="AEMQZL"
- DO ^DIC
- IF Y<1
- DO RESET
- QUIT
- +4 ;IHS/ITSC/WAR 7/31/03 BDGN is undefined coming from protocal ien 1519
- +5 ;Need to look at this more in the future
- IF '$DATA(BDGN)
- SET BDGN=+Y
- +6 SET DIE=9999999.91
- SET DR=".01:.03"
- SET DA=BDGN
- DO ^DIE
- +7 DO RESET
- +8 QUIT
- +9 ;
- 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)
