- BDGSYS2 ; IHS/ANMC/LJF - TREATING SPECIALTY SETUP ;
- ;;5.3;PIMS;;APR 26, 2002
- ;
- EN ; -- main entry point for BDG SYS TREAT SPEC SETUP
- NEW VALMCNT
- D TERM^VALM0,CLEAR^VALM1
- D EN^VALM("BDG SYS TREAT SPEC 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("Please wait while I compile the list...",1,0)
- NEW CODE,IEN,COUNT,LINE,Y
- S VALMCNT=0
- K ^TMP("BDGSYS2",$J)
- S NAME=0
- F S NAME=$O(^DIC(45.7,"B",NAME)) Q:NAME="" D
- . S IEN=0
- . F S IEN=$O(^DIC(45.7,"B",NAME,IEN)) Q:'IEN D
- .. S CODE=$$GET1^DIQ(45.7,IEN,9999999.01) Q:CODE="00" ;bad entry
- .. ;
- .. S COUNT=$G(COUNT)+1
- .. S LINE=$J(COUNT,2)_". "_NAME ;service name
- .. S LINE=$$PAD(LINE,32)_$$GET1^DIQ(45.7,IEN,99) ;abbreviation
- .. S LINE=$$PAD(LINE,39)_CODE
- .. S LINE=$$PAD(LINE,45)_$$SRV(IEN) ;hos service
- .. S LINE=$$PAD(LINE,61)_$$LASTDATE(IEN) ;active date
- .. D SET(LINE,COUNT,IEN,.VALMCNT)
- ;
- I '$D(^TMP("BDGSYS2",$J)) D
- . D SET("*** NO ENTRIES FOUND WITH IHS CODES!! ***",0,0,.VALMCNT)
- Q
- ;
- LASTDATE(N) ; find latest effective date and active status
- NEW X,Y
- I $$GET1^DIQ(45.7,N,9999999.03)'="YES" Q "" ;admitting service?
- S X=$O(^DIC(45.7,N,"E","ADATE","")) I X="" Q "No effective date"
- S Y=$O(^DIC(45.7,N,"E","ADATE",X,0)) I 'Y Q "Bad entry"
- I $$GET1^DIQ(45.702,Y_","_N,.02)'="YES" Q "Inactive" ;active?
- Q "YES - "_$$PAD($$FMTE^XLFDT(-X),14)
- ;
- SRV(N) ; returns hospital service for entry
- Q $E($P($$GET1^DIQ(45.7,IEN,2)," SERVICE"),1,15)
- ;
- SET(DATA,NUM,N,LINE) ; put display line into array
- S LINE=LINE+1
- S ^TMP("BDGSYS2",$J,LINE,0)=DATA
- S ^TMP("BDGSYS2",$J,"IDX",LINE,NUM)=N
- Q
- ;
- HELP ; -- help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- EXIT ; -- exit code
- K ^TMP("BDGSYS2",$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("BDGSYS2",$J,"IDX",Y)) Q:Y="" D
- .. S Z=$O(^TMP("BDGSYS2",$J,"IDX",Y,0))
- .. Q:^TMP("BDGSYS2",$J,"IDX",Y,Z)=""
- .. I Z=X S BDGN=^TMP("BDGSYS2",$J,"IDX",Y,Z)
- ;
- I 'BDGN D RESET Q
- S DDSFILE=45.7,DA=BDGN,DR="[BDG 45.7 SETUP]" D ^DDS
- 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)
- BDGSYS2 ; IHS/ANMC/LJF - TREATING SPECIALTY SETUP ;
- +1 ;;5.3;PIMS;;APR 26, 2002
- +2 ;
- EN ; -- main entry point for BDG SYS TREAT SPEC SETUP
- +1 NEW VALMCNT
- +2 DO TERM^VALM0
- DO CLEAR^VALM1
- +3 DO EN^VALM("BDG SYS TREAT SPEC 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("Please wait while I compile the list...",1,0)
- +2 NEW CODE,IEN,COUNT,LINE,Y
- +3 SET VALMCNT=0
- +4 KILL ^TMP("BDGSYS2",$JOB)
- +5 SET NAME=0
- +6 FOR
- SET NAME=$ORDER(^DIC(45.7,"B",NAME))
- IF NAME=""
- QUIT
- Begin DoDot:1
- +7 SET IEN=0
- +8 FOR
- SET IEN=$ORDER(^DIC(45.7,"B",NAME,IEN))
- IF 'IEN
- QUIT
- Begin DoDot:2
- +9 ;bad entry
- SET CODE=$$GET1^DIQ(45.7,IEN,9999999.01)
- IF CODE="00"
- QUIT
- +10 ;
- +11 SET COUNT=$GET(COUNT)+1
- +12 ;service name
- SET LINE=$JUSTIFY(COUNT,2)_". "_NAME
- +13 ;abbreviation
- SET LINE=$$PAD(LINE,32)_$$GET1^DIQ(45.7,IEN,99)
- +14 SET LINE=$$PAD(LINE,39)_CODE
- +15 ;hos service
- SET LINE=$$PAD(LINE,45)_$$SRV(IEN)
- +16 ;active date
- SET LINE=$$PAD(LINE,61)_$$LASTDATE(IEN)
- +17 DO SET(LINE,COUNT,IEN,.VALMCNT)
- End DoDot:2
- End DoDot:1
- +18 ;
- +19 IF '$DATA(^TMP("BDGSYS2",$JOB))
- Begin DoDot:1
- +20 DO SET("*** NO ENTRIES FOUND WITH IHS CODES!! ***",0,0,.VALMCNT)
- End DoDot:1
- +21 QUIT
- +22 ;
- LASTDATE(N) ; find latest effective date and active status
- +1 NEW X,Y
- +2 ;admitting service?
- IF $$GET1^DIQ(45.7,N,9999999.03)'="YES"
- QUIT ""
- +3 SET X=$ORDER(^DIC(45.7,N,"E","ADATE",""))
- IF X=""
- QUIT "No effective date"
- +4 SET Y=$ORDER(^DIC(45.7,N,"E","ADATE",X,0))
- IF 'Y
- QUIT "Bad entry"
- +5 ;active?
- IF $$GET1^DIQ(45.702,Y_","_N,.02)'="YES"
- QUIT "Inactive"
- +6 QUIT "YES - "_$$PAD($$FMTE^XLFDT(-X),14)
- +7 ;
- SRV(N) ; returns hospital service for entry
- +1 QUIT $EXTRACT($PIECE($$GET1^DIQ(45.7,IEN,2)," SERVICE"),1,15)
- +2 ;
- SET(DATA,NUM,N,LINE) ; put display line into array
- +1 SET LINE=LINE+1
- +2 SET ^TMP("BDGSYS2",$JOB,LINE,0)=DATA
- +3 SET ^TMP("BDGSYS2",$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("BDGSYS2",$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("BDGSYS2",$JOB,"IDX",Y))
- IF Y=""
- QUIT
- Begin DoDot:2
- +7 SET Z=$ORDER(^TMP("BDGSYS2",$JOB,"IDX",Y,0))
- +8 IF ^TMP("BDGSYS2",$JOB,"IDX",Y,Z)=""
- QUIT
- +9 IF Z=X
- SET BDGN=^TMP("BDGSYS2",$JOB,"IDX",Y,Z)
- End DoDot:2
- End DoDot:1
- +10 ;
- +11 IF 'BDGN
- DO RESET
- QUIT
- +12 SET DDSFILE=45.7
- SET DA=BDGN
- SET DR="[BDG 45.7 SETUP]"
- DO ^DDS
- +13 DO RESET
- +14 QUIT
- +15 ;
- 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)
