- BDGSYS3 ; IHS/ANMC/LJF - INPATIENT WARD SETUP ; [ 04/09/2004 8:18 AM ]
- ;;5.3;PIMS;**1005**;MAY 28, 2004
- ;IHS/OIT/LJF 04/27/2006 PATCH 1005 changed ScreenMan form to use authorization dates
- ;
- EN ; -- main entry point for BDG SYS WARD SETUP
- NEW VALMCNT
- D TERM^VALM0,CLEAR^VALM1
- D EN^VALM("BDG SYS WARD SETUP")
- 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
- D MSG^BDGF("Pleaes wait while I compile the list...",1,0)
- NEW IEN,DIV,INA,NAME
- S VALMCNT=0
- K ^TMP("BDGSYS3",$J),^TMP("BDGSYS31",$J)
- ;
- ; loop thru wards and sort by division, active/inactive, then name
- S NAME=0 F S NAME=$O(^DIC(42,"B",NAME)) Q:NAME="" D
- . S IEN=0 F S IEN=$O(^DIC(42,"B",NAME,IEN)) Q:'IEN D
- .. Q:'$D(^BDGWD(IEN)) ;not in IHS Ward file (old deleted ward?)
- .. S DIV=$$GET1^DIQ(42,IEN,.015) I DIV="" S DIV="??"
- .. S INA=$S($$GET1^DIQ(9009016.5,IEN,.03,"I")="I":"INACTIVE",1:"ACTIVE")
- .. S ^TMP("BDGSYS31",$J,DIV,INA,NAME,IEN)=""
- ;
- ; take sorted list and create display lines
- NEW A,B,C,D,COUNT
- S A=0 F S A=$O(^TMP("BDGSYS31",$J,A)) Q:A="" D
- . S B=0 F S B=$O(^TMP("BDGSYS31",$J,A,B)) Q:B="" D
- .. S C=0 F S C=$O(^TMP("BDGSYS31",$J,A,B,C)) Q:C="" D
- ... S D=0 F S D=$O(^TMP("BDGSYS31",$J,A,B,C,D)) Q:'D D
- .... D LINE(A,B,C,D,.COUNT)
- ;
- I '$D(^TMP("BDGSYS3",$J)) D
- . D SET("*** NO ENTRIES FOUND ***",0,0,.VALMCNT)
- K ^TMP("BDGSYS31",$J)
- Q
- ;
- LINE(DIV,INA,NAME,IEN,COUNT) ; create display line
- NEW LINE
- S COUNT=$G(COUNT)+1
- S LINE=$J(COUNT,2)_". "_NAME ;ward name
- S LINE=$$PAD(LINE,32)_$$GET1^DIQ(9009016.5,IEN,.02) ;abbrev
- S LINE=$$PAD(LINE,42)_$E(DIV,1,15) ;division
- ;
- I $$GET1^DIQ(9009016.5,IEN,.03)="INACTIVE" D Q ;inactive
- . S LINE=$$PAD(LINE,60)_"** INACTIVE **"
- . D SET(LINE,COUNT,IEN,.VALMCNT)
- ;
- S LINE=$$PAD(LINE,60)
- I $$GET1^DIQ(9009016.5,IEN,101)="YES" S LINE=LINE_" ICU"
- I $$GET1^DIQ(9009016.5,IEN,105)="YES" S LINE=LINE_" PCU"
- I $$GET1^DIQ(42,IEN,.09,"I")=1 S LINE=LINE_" SI WARD"
- D SET(LINE,COUNT,IEN,.VALMCNT)
- Q
- ;
- SET(DATA,NUM,N,LINE) ; put display line into array
- S LINE=LINE+1
- S ^TMP("BDGSYS3",$J,LINE,0)=DATA
- S ^TMP("BDGSYS3",$J,"IDX",LINE,NUM)=N
- Q
- ;
- HELP ; -- help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- EXIT ; -- exit code
- K ^TMP("BDGSYS3",$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
- ;
- ADD ;EP; called by Add Entry protocol
- NEW DIC,DLAYGO,Y,DDSFILE,DA,DR
- D FULL^VALM1
- ;
- NEW GNL F GNL=1:1 Q:'$D(^DIC(42,"AGL",GNL))
- S (DIC,DLAYGO)=42,DIC(0)="AEMQZL",DIC("DR")="44;.015;400///"_GNL
- ;
- D ^DIC K DIC I Y<1 D RESET Q
- S (DIC,DLAYGO)=9009016.5,DIC(0)="L",X=$P(Y,U,2),DINUM=+Y
- D ^DIC I Y<1 D RESET Q
- ;S DDSFILE=9009016.5,DA=+Y,DR="[BDG 9009016.5 SETUP]" D ^DDS
- S DDSFILE=9009016.5,DA=+Y,DR="[BDG 9009016.5 SETUP 2]" D ^DDS ;IHS/OIT/LJF 04/27/2006 PATCH 1005
- D RESET
- 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("BDGSYS3",$J,"IDX",Y)) Q:Y="" D
- .. S Z=$O(^TMP("BDGSYS3",$J,"IDX",Y,0))
- .. Q:^TMP("BDGSYS3",$J,"IDX",Y,Z)=""
- .. I Z=X S BDGN=^TMP("BDGSYS3",$J,"IDX",Y,Z)
- ;
- I 'BDGN D RESET Q
- ;S DDSFILE=9009016.5,DA=BDGN,DR="[BDG 9009016.5 SETUP]" D ^DDS
- S DDSFILE=9009016.5,DA=BDGN,DR="[BDG 9009016.5 SETUP 2]" D ^DDS ;IHS/OIT/LJF 04/27/2006 PATCH 1005
- 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)
- BDGSYS3 ; IHS/ANMC/LJF - INPATIENT WARD SETUP ; [ 04/09/2004 8:18 AM ]
- +1 ;;5.3;PIMS;**1005**;MAY 28, 2004
- +2 ;IHS/OIT/LJF 04/27/2006 PATCH 1005 changed ScreenMan form to use authorization dates
- +3 ;
- EN ; -- main entry point for BDG SYS WARD SETUP
- +1 NEW VALMCNT
- +2 DO TERM^VALM0
- DO CLEAR^VALM1
- +3 DO EN^VALM("BDG SYS WARD SETUP")
- +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 DO MSG^BDGF("Pleaes wait while I compile the list...",1,0)
- +2 NEW IEN,DIV,INA,NAME
- +3 SET VALMCNT=0
- +4 KILL ^TMP("BDGSYS3",$JOB),^TMP("BDGSYS31",$JOB)
- +5 ;
- +6 ; loop thru wards and sort by division, active/inactive, then name
- +7 SET NAME=0
- FOR
- SET NAME=$ORDER(^DIC(42,"B",NAME))
- IF NAME=""
- QUIT
- Begin DoDot:1
- +8 SET IEN=0
- FOR
- SET IEN=$ORDER(^DIC(42,"B",NAME,IEN))
- IF 'IEN
- QUIT
- Begin DoDot:2
- +9 ;not in IHS Ward file (old deleted ward?)
- IF '$DATA(^BDGWD(IEN))
- QUIT
- +10 SET DIV=$$GET1^DIQ(42,IEN,.015)
- IF DIV=""
- SET DIV="??"
- +11 SET INA=$SELECT($$GET1^DIQ(9009016.5,IEN,.03,"I")="I":"INACTIVE",1:"ACTIVE")
- +12 SET ^TMP("BDGSYS31",$JOB,DIV,INA,NAME,IEN)=""
- End DoDot:2
- End DoDot:1
- +13 ;
- +14 ; take sorted list and create display lines
- +15 NEW A,B,C,D,COUNT
- +16 SET A=0
- FOR
- SET A=$ORDER(^TMP("BDGSYS31",$JOB,A))
- IF A=""
- QUIT
- Begin DoDot:1
- +17 SET B=0
- FOR
- SET B=$ORDER(^TMP("BDGSYS31",$JOB,A,B))
- IF B=""
- QUIT
- Begin DoDot:2
- +18 SET C=0
- FOR
- SET C=$ORDER(^TMP("BDGSYS31",$JOB,A,B,C))
- IF C=""
- QUIT
- Begin DoDot:3
- +19 SET D=0
- FOR
- SET D=$ORDER(^TMP("BDGSYS31",$JOB,A,B,C,D))
- IF 'D
- QUIT
- Begin DoDot:4
- +20 DO LINE(A,B,C,D,.COUNT)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +21 ;
- +22 IF '$DATA(^TMP("BDGSYS3",$JOB))
- Begin DoDot:1
- +23 DO SET("*** NO ENTRIES FOUND ***",0,0,.VALMCNT)
- End DoDot:1
- +24 KILL ^TMP("BDGSYS31",$JOB)
- +25 QUIT
- +26 ;
- LINE(DIV,INA,NAME,IEN,COUNT) ; create display line
- +1 NEW LINE
- +2 SET COUNT=$GET(COUNT)+1
- +3 ;ward name
- SET LINE=$JUSTIFY(COUNT,2)_". "_NAME
- +4 ;abbrev
- SET LINE=$$PAD(LINE,32)_$$GET1^DIQ(9009016.5,IEN,.02)
- +5 ;division
- SET LINE=$$PAD(LINE,42)_$EXTRACT(DIV,1,15)
- +6 ;
- +7 ;inactive
- IF $$GET1^DIQ(9009016.5,IEN,.03)="INACTIVE"
- Begin DoDot:1
- +8 SET LINE=$$PAD(LINE,60)_"** INACTIVE **"
- +9 DO SET(LINE,COUNT,IEN,.VALMCNT)
- End DoDot:1
- QUIT
- +10 ;
- +11 SET LINE=$$PAD(LINE,60)
- +12 IF $$GET1^DIQ(9009016.5,IEN,101)="YES"
- SET LINE=LINE_" ICU"
- +13 IF $$GET1^DIQ(9009016.5,IEN,105)="YES"
- SET LINE=LINE_" PCU"
- +14 IF $$GET1^DIQ(42,IEN,.09,"I")=1
- SET LINE=LINE_" SI WARD"
- +15 DO SET(LINE,COUNT,IEN,.VALMCNT)
- +16 QUIT
- +17 ;
- SET(DATA,NUM,N,LINE) ; put display line into array
- +1 SET LINE=LINE+1
- +2 SET ^TMP("BDGSYS3",$JOB,LINE,0)=DATA
- +3 SET ^TMP("BDGSYS3",$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("BDGSYS3",$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 ;
- ADD ;EP; called by Add Entry protocol
- +1 NEW DIC,DLAYGO,Y,DDSFILE,DA,DR
- +2 DO FULL^VALM1
- +3 ;
- +4 NEW GNL
- FOR GNL=1:1
- IF '$DATA(^DIC(42,"AGL",GNL))
- QUIT
- +5 SET (DIC,DLAYGO)=42
- SET DIC(0)="AEMQZL"
- SET DIC("DR")="44;.015;400///"_GNL
- +6 ;
- +7 DO ^DIC
- KILL DIC
- IF Y<1
- DO RESET
- QUIT
- +8 SET (DIC,DLAYGO)=9009016.5
- SET DIC(0)="L"
- SET X=$PIECE(Y,U,2)
- SET DINUM=+Y
- +9 DO ^DIC
- IF Y<1
- DO RESET
- QUIT
- +10 ;S DDSFILE=9009016.5,DA=+Y,DR="[BDG 9009016.5 SETUP]" D ^DDS
- +11 ;IHS/OIT/LJF 04/27/2006 PATCH 1005
- SET DDSFILE=9009016.5
- SET DA=+Y
- SET DR="[BDG 9009016.5 SETUP 2]"
- DO ^DDS
- +12 DO RESET
- +13 QUIT
- +14 ;
- 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("BDGSYS3",$JOB,"IDX",Y))
- IF Y=""
- QUIT
- Begin DoDot:2
- +7 SET Z=$ORDER(^TMP("BDGSYS3",$JOB,"IDX",Y,0))
- +8 IF ^TMP("BDGSYS3",$JOB,"IDX",Y,Z)=""
- QUIT
- +9 IF Z=X
- SET BDGN=^TMP("BDGSYS3",$JOB,"IDX",Y,Z)
- End DoDot:2
- End DoDot:1
- +10 ;
- +11 IF 'BDGN
- DO RESET
- QUIT
- +12 ;S DDSFILE=9009016.5,DA=BDGN,DR="[BDG 9009016.5 SETUP]" D ^DDS
- +13 ;IHS/OIT/LJF 04/27/2006 PATCH 1005
- SET DDSFILE=9009016.5
- SET DA=BDGN
- SET DR="[BDG 9009016.5 SETUP 2]"
- DO ^DDS
- +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)
