- BDGICSET ;IHS/OIT/LJF - SET UP DATES FOR USE UNDER ICE;
- ;;5.3;PIMS;**1004,1005**;MAY 28, 2004
- ;IHS/OIT/LJF 09/08/2005 PATCH 1004 New routine
- ;IHS/OIT/LJF 04/20/2006 PATCH 1005 added STAFF subroutine
- ; added display of medical staff
- ;
- EN ; -- main entry point for BDG IC SETUP ICE
- NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
- D EN^VALM("BDG IC SETUP ICE")
- Q
- ;
- HDR ; -- header code
- NEW X S X=$$GET1^DIQ(4,DUZ(2),.01)
- S VALMHDR(1)=$$SP(75-$L(X)\2)_X
- Q
- ;
- INIT ; -- init variables and list array
- NEW FAC,LINE,FIELD
- S VALMCNT=0 K ^TMP("BDGICSET",$J)
- S FAC=$O(^BDGPAR("B",+$$DIV^BSDU,0)) I 'FAC D NONE Q
- ;
- F FIELD=.08,.12,201,.07,.13,202:1:208 D
- . S LINE=" "_$$PAD($$LABEL(FIELD)_":",50)_$$GET1^DIQ(9009020.1,FAC,FIELD)
- . D SET(LINE,.VALMCNT)
- . I FIELD=.13 D SET("",.VALMCNT)
- . I FIELD=206 D SET($$PAD(" DATE CHART COMPLETED USED IN ICE"_":",51)_"REQUIRED",.VALMCNT)
- ;
- ;IHS/OIT/LJF 04/20/2006 PATCH 1005 added display of medical staff for IC reports
- D SET("",.VALMCNT),SET("",.VALMCNT)
- D SET($$SP(10)_"*** MEDICAL STAFF INCLUDED ON SCREENED IC REPORTS ***",.VALMCNT)
- NEW IEN,CLASS,INACTIVE
- S IEN=0 F S IEN=$O(^BDGPAR(FAC,3,IEN)) Q:'IEN D
- . S PRV=$$GET1^DIQ(9009020.13,IEN_","_FAC,.01,"I")
- . S CLASS=$$PAD($E($$GET1^DIQ(200,PRV,53.5),1,20),23)
- . S INACTIVE=$$GET1^DIQ(200,PRV,53.4) I INACTIVE]"" S INACTIVE="Inactivated on "_INACTIVE
- . D SET($$PAD($E($$GET1^DIQ(200,PRV,.01),1,27),30)_CLASS_INACTIVE,.VALMCNT)
- ;end of PATCH 1005 new code
- ;
- NONE ; if none found
- I '$D(^TMP("BDGICSET",$J)) D
- . S VALMCNT=1
- . S ^TMP("BDGICSET",$J,1,0)=$$SP(15)_"NO INFORMATION FOUND - CALL COMPUTER SUPPORT"
- Q
- ;
- LABEL(FIELD) ; returns field's title or label
- NEW X
- S X=$$GET1^DID(9009020.1,FIELD,"","TITLE")
- I X="" S X=$$GET1^DID(9009020.1,FIELD,"","LABEL")
- Q X
- ;
- SET(DATA,COUNT) ; put data into display line
- S COUNT=COUNT+1
- S ^TMP("BDGICSET",$J,COUNT,0)=DATA
- Q
- ;
- EDIT ;EP; called by BDG IS SETUP EDIT protocol
- D FULL^VALM1
- NEW DIE,DA,DR
- S DA=$O(^BDGPAR("B",+$$DIV^BSDU,0))
- I DA S DIE="^BDGPAR(",DR=".08;.12;201;.07;.13;202:208" D ^DIE
- S VALMBCK="R" D TERM^VALM0,HDR,INIT
- Q
- ;
- ;IHS/OIT/LJF 04/20/2006 PATCH 1005 added this subroutine
- STAFF ;EP; called by BDG IC MED STAFF protocol
- D FULL^VALM1
- S DA=$O(^BDGPAR("B",+$$DIV^BSDU,0))
- S DIE="^BDGPAR(",DR="3" D ^DIE
- S VALMBCK="R" D TERM^VALM0,HDR,INIT
- Q
- ;
- HELP ; -- help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- EXIT ; -- exit code
- K ^TMP("BDGICSET",$J)
- Q
- ;
- EXPND ; -- expand code
- 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)
- BDGICSET ;IHS/OIT/LJF - SET UP DATES FOR USE UNDER ICE;
- +1 ;;5.3;PIMS;**1004,1005**;MAY 28, 2004
- +2 ;IHS/OIT/LJF 09/08/2005 PATCH 1004 New routine
- +3 ;IHS/OIT/LJF 04/20/2006 PATCH 1005 added STAFF subroutine
- +4 ; added display of medical staff
- +5 ;
- EN ; -- main entry point for BDG IC SETUP ICE
- +1 NEW VALMCNT
- DO TERM^VALM0
- DO CLEAR^VALM1
- +2 DO EN^VALM("BDG IC SETUP ICE")
- +3 QUIT
- +4 ;
- HDR ; -- header code
- +1 NEW X
- SET X=$$GET1^DIQ(4,DUZ(2),.01)
- +2 SET VALMHDR(1)=$$SP(75-$LENGTH(X)\2)_X
- +3 QUIT
- +4 ;
- INIT ; -- init variables and list array
- +1 NEW FAC,LINE,FIELD
- +2 SET VALMCNT=0
- KILL ^TMP("BDGICSET",$JOB)
- +3 SET FAC=$ORDER(^BDGPAR("B",+$$DIV^BSDU,0))
- IF 'FAC
- DO NONE
- QUIT
- +4 ;
- +5 FOR FIELD=.08,.12,201,.07,.13,202:1:208
- Begin DoDot:1
- +6 SET LINE=" "_$$PAD($$LABEL(FIELD)_":",50)_$$GET1^DIQ(9009020.1,FAC,FIELD)
- +7 DO SET(LINE,.VALMCNT)
- +8 IF FIELD=.13
- DO SET("",.VALMCNT)
- +9 IF FIELD=206
- DO SET($$PAD(" DATE CHART COMPLETED USED IN ICE"_":",51)_"REQUIRED",.VALMCNT)
- End DoDot:1
- +10 ;
- +11 ;IHS/OIT/LJF 04/20/2006 PATCH 1005 added display of medical staff for IC reports
- +12 DO SET("",.VALMCNT)
- DO SET("",.VALMCNT)
- +13 DO SET($$SP(10)_"*** MEDICAL STAFF INCLUDED ON SCREENED IC REPORTS ***",.VALMCNT)
- +14 NEW IEN,CLASS,INACTIVE
- +15 SET IEN=0
- FOR
- SET IEN=$ORDER(^BDGPAR(FAC,3,IEN))
- IF 'IEN
- QUIT
- Begin DoDot:1
- +16 SET PRV=$$GET1^DIQ(9009020.13,IEN_","_FAC,.01,"I")
- +17 SET CLASS=$$PAD($EXTRACT($$GET1^DIQ(200,PRV,53.5),1,20),23)
- +18 SET INACTIVE=$$GET1^DIQ(200,PRV,53.4)
- IF INACTIVE]""
- SET INACTIVE="Inactivated on "_INACTIVE
- +19 DO SET($$PAD($EXTRACT($$GET1^DIQ(200,PRV,.01),1,27),30)_CLASS_INACTIVE,.VALMCNT)
- End DoDot:1
- +20 ;end of PATCH 1005 new code
- +21 ;
- NONE ; if none found
- +1 IF '$DATA(^TMP("BDGICSET",$JOB))
- Begin DoDot:1
- +2 SET VALMCNT=1
- +3 SET ^TMP("BDGICSET",$JOB,1,0)=$$SP(15)_"NO INFORMATION FOUND - CALL COMPUTER SUPPORT"
- End DoDot:1
- +4 QUIT
- +5 ;
- LABEL(FIELD) ; returns field's title or label
- +1 NEW X
- +2 SET X=$$GET1^DID(9009020.1,FIELD,"","TITLE")
- +3 IF X=""
- SET X=$$GET1^DID(9009020.1,FIELD,"","LABEL")
- +4 QUIT X
- +5 ;
- SET(DATA,COUNT) ; put data into display line
- +1 SET COUNT=COUNT+1
- +2 SET ^TMP("BDGICSET",$JOB,COUNT,0)=DATA
- +3 QUIT
- +4 ;
- EDIT ;EP; called by BDG IS SETUP EDIT protocol
- +1 DO FULL^VALM1
- +2 NEW DIE,DA,DR
- +3 SET DA=$ORDER(^BDGPAR("B",+$$DIV^BSDU,0))
- +4 IF DA
- SET DIE="^BDGPAR("
- SET DR=".08;.12;201;.07;.13;202:208"
- DO ^DIE
- +5 SET VALMBCK="R"
- DO TERM^VALM0
- DO HDR
- DO INIT
- +6 QUIT
- +7 ;
- +8 ;IHS/OIT/LJF 04/20/2006 PATCH 1005 added this subroutine
- STAFF ;EP; called by BDG IC MED STAFF protocol
- +1 DO FULL^VALM1
- +2 SET DA=$ORDER(^BDGPAR("B",+$$DIV^BSDU,0))
- +3 SET DIE="^BDGPAR("
- SET DR="3"
- DO ^DIE
- +4 SET VALMBCK="R"
- DO TERM^VALM0
- DO HDR
- DO INIT
- +5 QUIT
- +6 ;
- HELP ; -- help code
- +1 SET X="?"
- DO DISP^XQORM1
- WRITE !!
- +2 QUIT
- +3 ;
- EXIT ; -- exit code
- +1 KILL ^TMP("BDGICSET",$JOB)
- +2 QUIT
- +3 ;
- EXPND ; -- expand code
- +1 QUIT
- +2 ;
- 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)
