IBDFUTL5 ;ALB/MKN/CFS - CONTINUED FROM IBDUTL4 ;12/30/2011
;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;Dec 30, 2011;Build 80
;
;
CHECKCL(IBDCLIN,IBDTAINS,IBDSORT,ARY,IBDGPNA) ;Check by Clinic
; -- input IBDCLIN = IEN of Clinic file
; IBDTAINS = 9 or 10 or B or N or A
; -- output is an array in ARY as follows:
; @ARY(0) = Number of rows in @ARY
; @ARY(#) = P1 := Encounter Form name
; P2 := Contains ICD-9/ICD-10/BOTH
; P3 := Date Last Edited ICD-9
; P4 := Date Last Edited ICD-10
; P5 := ICD-10 Update Status
; P6 := Clinic Name
;
N IBDI9,IBDI10,IBDX,IBDI,IBDQUIT,IBDFORMS,IBDFORM,IBDBLK,IBDY9,IBDY10,IBDLIST,IBDRES,IBDADD,IBDCLNA,IBDDATA,IBDBLKX
N IBDFMNA,IBDFMX,IBDOK,IBDSUB,IBDDET,IBDSELX,IBDBLKNA,IBDLI,IBDSC
;
I $G(IBDCLIN)="" G CHECKCLQ
I $G(^SC(IBDCLIN,0))="" G CHECKCLQ
S IBDCLNA=$P(^SC(IBDCLIN,0),U,1) S:IBDCLNA="" IBDCLNA="Unknown"
S IBDFORMS=$G(^SD(409.95,+$O(^SD(409.95,"B",IBDCLIN,0)),0))
G:IBDFORMS="" CHECKCLQ
F IBDI=2,3,4,6,8,9 S IBDFORM=$P(IBDFORMS,U,IBDI) I IBDFORM?1.N D CHECKFRM
;
CHECKCLQ ;
Q
;
CHECKFM(IBDEFORM,IBDTAINS,IBDSORT,ARY,IBDGPNA) ;Check by Form
; -- input IBDEFORM = IEN of Encounter Form file
; IBDTAINS = 9 or 10 or B or N or A
; -- output is an array in ARY as follows:
; @ARY(0) = Number of rows in @ARY
; @ARY(#) = P1 := Encounter Form name
; P2 := Contains ICD-9/ICD-10/BOTH
; P3 := Date Last Edited ICD-9
; P4 := Date Last Edited ICD-10
; P5 := ICD-10 Update Status
; P6 := Clinic Name
;
N IBDI9,IBDI10,IBDX,IBDI,IBDQUIT,IBDFORMS,IBDFORM,IBDBLK,IBDY9,IBDY10,IBDLIST,IBDRES,IBDADD,IBDCLNA,IBDDATA,IBDBLKX
N IBDFMNA,IBDFMX,IBDFMSTA,IBDOK,IBDSUB,IBD9ED,IBD10ED,IBDLTSEL,IBDDET,IBDSELX,IBDBLKNA,IBDLI,IBDSC,IBDSYS,IBDCL,IBDYES
;
S IBDX=$G(^IBE(357,IBDEFORM,0)) I IBDX="" G CHECKFMQ
S IBDFMNA=$P(^IBE(357,IBDEFORM,0),U,1) G:IBDFMNA="" CHECKFMQ
I (+$P(IBDX,U,7))&(($P(IBDX,U)="TOOL KIT")!($P(IBDX,U)="WORKCOPY")) G CHECKFMQ ; Ignore TOOLKIT and WORCOPY forms per SMES 2/29/12
S IBDFORM=IBDEFORM,IBDCL=$O(^TMP("IBDFUTL4",$J,"X","FMARR",IBDFMNA,""))
I IBDCL="" S IBDCLNA="",IBDCLIN=""
I IBDCL?1.N S IBDX=$G(^SC(IBDCL,0)) G:IBDX="" CHECKFMQ S IBDCLNA=$P(IBDX,U,1)
D CHECKFRM
;
CHECKFMQ ;
Q
;
CHECKFRM ;Check this Form - go through each Block attached to Form, check ICD-9/ICD-10 relevance against user input selection\
;
N IBDBLHD,IBDPIEN,IBDX,IBDY,IBDADD,IBDWH,IBDQUIT,IBDRES,IBD9ED,IBD10ED,IBDFMSTA,IBD9HIS,IBD10HIS,IBDLTSEL,IBDSYS,IBDCODE
S (IBDY9,IBDY10,IBDBLK,IBDADD,IBDYES,IBDQUIT)=0,(IBD9HIS,IBD10HIS,IBD9ED,IBD10ED,IBDFMSTA)=""
S IBDX=$O(^IBE(357,IBDFORM,3,"B",1,"")) I IBDX?1.N S IBD9HIS=^IBE(357,IBDFORM,3,IBDX,0),IBDFMSTA=$P(IBD9HIS,U,2)
S IBDX=$O(^IBE(357,IBDFORM,3,"B",30,"")) I IBDX?1.N S IBD10HIS=^IBE(357,IBDFORM,3,IBDX,0),IBDFMSTA=$P(IBD10HIS,U,2)
I IBDINP("STATUS")'="A" D
. I IBDX="",IBDINP("STATUS")'="I" S IBDQUIT=1 Q
. I IBDX'="" D
. . I IBDINP("STATUS")="I",IBDFMSTA'="" S IBDQUIT=1 Q
. . I IBDINP("STATUS")="C",IBDFMSTA'="C" S IBDQUIT=1 Q
. . I IBDINP("STATUS")="R",IBDFMSTA'="R" S IBDQUIT=1 Q
Q:IBDQUIT
;
S IBD9ED=$P(IBD9HIS,U,3),IBD10ED=$P(IBD10HIS,U,3) ;Seed the Edit Dates for checking at Selection level below
;
K IBDDET ;This will contain Detail lines if Detail option selected
S IBDFMX=$G(^IBE(357,IBDFORM,0)),IBDFMNA=$P(IBDFMX,U,1) S:IBDFMNA="" IBDFMNA="Unknown"
I IBDINP("SORTBY")="SF" Q:'$D(IBDINP("FORM",IBDFMNA))
I IBDINP("SORTBY")="RF" Q:IBDINP("FORM","RF",1)]IBDFMNA!(IBDFMNA]IBDINP("FORM","RF",2))
;This loop goes through all blocks and lists and sets the flags where ICD-9 or ICD-10 are present
F S IBDBLK=$O(^IBE(357.1,"C",IBDFORM,IBDBLK)) Q:'IBDBLK S IBDLIST=0 D
. S IBDX=^IBE(357.1,IBDBLK,0),IBDBLKNA=$P(IBDX,U,1),IBDBLHD=""
. F S IBDLIST=$O(^IBE(357.2,"C",IBDBLK,IBDLIST)) Q:'IBDLIST D
. . S IBDX=^IBE(357.2,IBDLIST,0),IBDPIEN=$P(IBDX,U,11) ;Package Interface IEN
. . S IBDX=^IBE(357.6,IBDPIEN,0),IBDSYS=$P(IBDX,U,22) Q:IBDSYS'=1&(IBDSYS'=30) ;Coding System field
. . I IBDSYS?1.N S IBDX=$$SINFO^ICDEX(IBDSYS) S:$P(IBDX,U,2)="ICD-9-CM" IBDY9=1 S:$P(IBDX,U,2)="ICD-10-CM" IBDY10=1
. . ;Now compare with the user selection - ICD9/ICD10/Both/Neither
. . I IBDTAINS=9,IBDY9=0 Q
. . I IBDTAINS=10,IBDY10=0 Q
. . I IBDTAINS="B",IBDY9=0!(IBDY10=0) Q
. . I IBDTAINS="N",IBDY9=1!(IBDY10=1) Q
. . ;Now find ICD-9/10 Status and history dates at the Selection level and update Latest Edit date where required
. . K ^TMP("IBDFUTL4X",$J,"X","BLCODE")
. . S IBDLTSEL="" F S IBDLTSEL=$O(^IBE(357.3,"C",IBDLIST,IBDLTSEL)) Q:IBDLTSEL="" D
. . . S IBDX=$G(^IBE(357.3,IBDLTSEL,4))
. . . I $P(IBDX,U,1)>IBD9ED S IBD9ED=$P(IBDX,U,1)
. . . I $P(IBDX,U,2)>IBD10ED S IBD10ED=$P(IBDX,U,1)
. . . I IBDINP("SD")="D" D
. . . . S:IBDBLHD="" IBDX=$O(IBDDET(""),-1)+1,IBDDET(IBDX)="BL^"_IBDBLKNA,IBDBLHD=IBDBLKNA
. . . . S IBDX=^IBE(357.3,IBDLTSEL,0),IBDDATA=$$ICDDATA^ICDXCODE(IBDSYS,$P(IBDX,U,1)),IBDCODE=$P(IBDX,U,1)
. . . . I '$D(^TMP("IBDFUTL4X",$J,"X","BLCODE",IBDCODE)) S IBDSELX="LT^"_IBDLTSEL_U_IBDCODE_U_$P(IBDDATA,U,4),IBDX=$O(IBDDET(""),-1)+1,IBDDET(IBDX)=IBDSELX,^TMP("IBDFUTL4X",$J,"X","BLCODE",IBDCODE)=""
;We are now back at form level (357) and we know this form needs to be included in the list if user selection agrees
S IBDYES=1 D
.I IBDTAINS=9&((IBDY9=0)!(IBDY10=1)) S IBDYES=0 Q
.I IBDTAINS=10&((IBDY9=1)!(IBDY10=0)) S IBDYES=0 Q
.I IBDTAINS="B"&((IBDY9=0)!(IBDY10=0)) S IBDYES=0 Q
.I IBDTAINS="N"&((IBDY9=1)!(IBDY10=1)) S IBDYES=0 Q
Q:IBDYES=0
S IBDRES=""
I IBDY9=1 S IBDRES="ICD9"
I IBDY10=1 D
. I IBDY9=1 S IBDRES="BOTH"
. E S IBDRES="ICD10"
I $E(IBDSORT,2)="C" S IBDSUB=IBDCLNA D SET
I $E(IBDSORT,2)="F" S IBDSUB=IBDFMNA D SET
I $E(IBDSORT,2)="G" S IBDSUB=IBDGPNA D SET
Q
;
SET ;
N IBDY,IBD9DA,IBD10DA
S (IBD9DA,IBD10DA)=""
I IBD9ED>0 S IBD9DA=$E(IBD9ED,4,5)_"/"_$E(IBD9ED,6,7)_"/"_$E(IBD9ED,2,3)
I IBD10ED>0 S IBD10DA=$E(IBD10ED,4,5)_"/"_$E(IBD10ED,6,7)_"/"_$E(IBD10ED,2,3)
S IBDY=$S(IBDFMSTA="":"",IBDFMSTA="C":"COMP",IBDFMSTA="I":"",IBDFMSTA="R":"REV",1:"")
I $E(IBDSORT,2)'="G" D
. S @ARY@("S",IBDSUB,IBDFMNA)=IBDFMNA_U_IBDRES_U_IBD9DA_U_IBD10DA_U_IBDY_U_IBDCLNA_U_IBDCLIN_U_IBDFORM_U_$G(IBDGPNA)
. I IBDINP("SD")="D" M @ARY@("S",IBDSUB,IBDFMNA,"D")=IBDDET
I $E(IBDSORT,2)="G" D
. I IBDGPNA="" S IBDGPNA="Unknown"
. S @ARY@("S",IBDGPNA,IBDCLNA,IBDFMNA)=IBDFMNA_U_IBDRES_U_IBD9DA_U_IBD10DA_U_IBDY_U_IBDCLNA_U_IBDCLIN_U_IBDFORM_U_IBDGPNA
. I IBDINP("SD")="D" M @ARY@("S",IBDGPNA,IBDCLNA,IBDFMNA,"D")=IBDDET
Q
;
GRHEADNG(IBDGPNA,IBDCT) ;List each clinic under its grouped heading.
N IBDX
S IBDX="",IBDX=$$SETSTR^VALM1(" ",IBDX,1,3)
S ^TMP("IBDFUTL4",$J,IBDCT,0)=IBDX
S ^TMP("IBDFUTL4X",$J,"X","GPNA",IBDGPNA,IBDCT)=""
S IBDCT=IBDCT+1,VALMCNT=VALMCNT+1
S IBDVAL1=$L(IBDGPNA) S IBDVAL1=(80-IBDVAL1)/2 S IBDVAL1=IBDVAL1\1 S IBDX="",IBDX=$$SETSTR^VALM1(" ",IBDX,1,IBDVAL1)
S IBDX=$$SETSTR^VALM1(IBDGPNA,IBDX,IBDVAL1,25)
S ^TMP("IBDFUTL4",$J,IBDCT,0)=IBDX
S ^TMP("IBDFUTL4X",$J,"X","GPNA",IBDGPNA,IBDCT)=""
S IBDCT=IBDCT+1,VALMCNT=VALMCNT+1
D CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
S IBDX="",IBDX=$$SETSTR^VALM1(" ",IBDX,1,3)
S ^TMP("IBDFUTL4",$J,IBDCT,0)=IBDX
S ^TMP("IBDFUTL4X",$J,"X","GPNA",IBDGPNA,IBDCT)=""
S IBDCT=IBDCT+1,VALMCNT=VALMCNT+1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFUTL5 7567 printed Apr 09, 2024@21:08:44 Page 2
IBDFUTL5 ;ALB/MKN/CFS - CONTINUED FROM IBDUTL4 ;12/30/2011
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;Dec 30, 2011;Build 80
+2 ;
+3 ;
CHECKCL(IBDCLIN,IBDTAINS,IBDSORT,ARY,IBDGPNA) ;Check by Clinic
+1 ; -- input IBDCLIN = IEN of Clinic file
+2 ; IBDTAINS = 9 or 10 or B or N or A
+3 ; -- output is an array in ARY as follows:
+4 ; @ARY(0) = Number of rows in @ARY
+5 ; @ARY(#) = P1 := Encounter Form name
+6 ; P2 := Contains ICD-9/ICD-10/BOTH
+7 ; P3 := Date Last Edited ICD-9
+8 ; P4 := Date Last Edited ICD-10
+9 ; P5 := ICD-10 Update Status
+10 ; P6 := Clinic Name
+11 ;
+12 NEW IBDI9,IBDI10,IBDX,IBDI,IBDQUIT,IBDFORMS,IBDFORM,IBDBLK,IBDY9,IBDY10,IBDLIST,IBDRES,IBDADD,IBDCLNA,IBDDATA,IBDBLKX
+13 NEW IBDFMNA,IBDFMX,IBDOK,IBDSUB,IBDDET,IBDSELX,IBDBLKNA,IBDLI,IBDSC
+14 ;
+15 IF $GET(IBDCLIN)=""
GOTO CHECKCLQ
+16 IF $GET(^SC(IBDCLIN,0))=""
GOTO CHECKCLQ
+17 SET IBDCLNA=$PIECE(^SC(IBDCLIN,0),U,1)
if IBDCLNA=""
SET IBDCLNA="Unknown"
+18 SET IBDFORMS=$GET(^SD(409.95,+$ORDER(^SD(409.95,"B",IBDCLIN,0)),0))
+19 if IBDFORMS=""
GOTO CHECKCLQ
+20 FOR IBDI=2,3,4,6,8,9
SET IBDFORM=$PIECE(IBDFORMS,U,IBDI)
IF IBDFORM?1.N
DO CHECKFRM
+21 ;
CHECKCLQ ;
+1 QUIT
+2 ;
CHECKFM(IBDEFORM,IBDTAINS,IBDSORT,ARY,IBDGPNA) ;Check by Form
+1 ; -- input IBDEFORM = IEN of Encounter Form file
+2 ; IBDTAINS = 9 or 10 or B or N or A
+3 ; -- output is an array in ARY as follows:
+4 ; @ARY(0) = Number of rows in @ARY
+5 ; @ARY(#) = P1 := Encounter Form name
+6 ; P2 := Contains ICD-9/ICD-10/BOTH
+7 ; P3 := Date Last Edited ICD-9
+8 ; P4 := Date Last Edited ICD-10
+9 ; P5 := ICD-10 Update Status
+10 ; P6 := Clinic Name
+11 ;
+12 NEW IBDI9,IBDI10,IBDX,IBDI,IBDQUIT,IBDFORMS,IBDFORM,IBDBLK,IBDY9,IBDY10,IBDLIST,IBDRES,IBDADD,IBDCLNA,IBDDATA,IBDBLKX
+13 NEW IBDFMNA,IBDFMX,IBDFMSTA,IBDOK,IBDSUB,IBD9ED,IBD10ED,IBDLTSEL,IBDDET,IBDSELX,IBDBLKNA,IBDLI,IBDSC,IBDSYS,IBDCL,IBDYES
+14 ;
+15 SET IBDX=$GET(^IBE(357,IBDEFORM,0))
IF IBDX=""
GOTO CHECKFMQ
+16 SET IBDFMNA=$PIECE(^IBE(357,IBDEFORM,0),U,1)
if IBDFMNA=""
GOTO CHECKFMQ
+17 ; Ignore TOOLKIT and WORCOPY forms per SMES 2/29/12
IF (+$PIECE(IBDX,U,7))&(($PIECE(IBDX,U)="TOOL KIT")!($PIECE(IBDX,U)="WORKCOPY"))
GOTO CHECKFMQ
+18 SET IBDFORM=IBDEFORM
SET IBDCL=$ORDER(^TMP("IBDFUTL4",$JOB,"X","FMARR",IBDFMNA,""))
+19 IF IBDCL=""
SET IBDCLNA=""
SET IBDCLIN=""
+20 IF IBDCL?1.N
SET IBDX=$GET(^SC(IBDCL,0))
if IBDX=""
GOTO CHECKFMQ
SET IBDCLNA=$PIECE(IBDX,U,1)
+21 DO CHECKFRM
+22 ;
CHECKFMQ ;
+1 QUIT
+2 ;
CHECKFRM ;Check this Form - go through each Block attached to Form, check ICD-9/ICD-10 relevance against user input selection\
+1 ;
+2 NEW IBDBLHD,IBDPIEN,IBDX,IBDY,IBDADD,IBDWH,IBDQUIT,IBDRES,IBD9ED,IBD10ED,IBDFMSTA,IBD9HIS,IBD10HIS,IBDLTSEL,IBDSYS,IBDCODE
+3 SET (IBDY9,IBDY10,IBDBLK,IBDADD,IBDYES,IBDQUIT)=0
SET (IBD9HIS,IBD10HIS,IBD9ED,IBD10ED,IBDFMSTA)=""
+4 SET IBDX=$ORDER(^IBE(357,IBDFORM,3,"B",1,""))
IF IBDX?1.N
SET IBD9HIS=^IBE(357,IBDFORM,3,IBDX,0)
SET IBDFMSTA=$PIECE(IBD9HIS,U,2)
+5 SET IBDX=$ORDER(^IBE(357,IBDFORM,3,"B",30,""))
IF IBDX?1.N
SET IBD10HIS=^IBE(357,IBDFORM,3,IBDX,0)
SET IBDFMSTA=$PIECE(IBD10HIS,U,2)
+6 IF IBDINP("STATUS")'="A"
Begin DoDot:1
+7 IF IBDX=""
IF IBDINP("STATUS")'="I"
SET IBDQUIT=1
QUIT
+8 IF IBDX'=""
Begin DoDot:2
+9 IF IBDINP("STATUS")="I"
IF IBDFMSTA'=""
SET IBDQUIT=1
QUIT
+10 IF IBDINP("STATUS")="C"
IF IBDFMSTA'="C"
SET IBDQUIT=1
QUIT
+11 IF IBDINP("STATUS")="R"
IF IBDFMSTA'="R"
SET IBDQUIT=1
QUIT
End DoDot:2
End DoDot:1
+12 if IBDQUIT
QUIT
+13 ;
+14 ;Seed the Edit Dates for checking at Selection level below
SET IBD9ED=$PIECE(IBD9HIS,U,3)
SET IBD10ED=$PIECE(IBD10HIS,U,3)
+15 ;
+16 ;This will contain Detail lines if Detail option selected
KILL IBDDET
+17 SET IBDFMX=$GET(^IBE(357,IBDFORM,0))
SET IBDFMNA=$PIECE(IBDFMX,U,1)
if IBDFMNA=""
SET IBDFMNA="Unknown"
+18 IF IBDINP("SORTBY")="SF"
if '$DATA(IBDINP("FORM",IBDFMNA))
QUIT
+19 IF IBDINP("SORTBY")="RF"
if IBDINP("FORM","RF",1)]IBDFMNA!(IBDFMNA]IBDINP("FORM","RF",2))
QUIT
+20 ;This loop goes through all blocks and lists and sets the flags where ICD-9 or ICD-10 are present
+21 FOR
SET IBDBLK=$ORDER(^IBE(357.1,"C",IBDFORM,IBDBLK))
if 'IBDBLK
QUIT
SET IBDLIST=0
Begin DoDot:1
+22 SET IBDX=^IBE(357.1,IBDBLK,0)
SET IBDBLKNA=$PIECE(IBDX,U,1)
SET IBDBLHD=""
+23 FOR
SET IBDLIST=$ORDER(^IBE(357.2,"C",IBDBLK,IBDLIST))
if 'IBDLIST
QUIT
Begin DoDot:2
+24 ;Package Interface IEN
SET IBDX=^IBE(357.2,IBDLIST,0)
SET IBDPIEN=$PIECE(IBDX,U,11)
+25 ;Coding System field
SET IBDX=^IBE(357.6,IBDPIEN,0)
SET IBDSYS=$PIECE(IBDX,U,22)
if IBDSYS'=1&(IBDSYS'=30)
QUIT
+26 IF IBDSYS?1.N
SET IBDX=$$SINFO^ICDEX(IBDSYS)
if $PIECE(IBDX,U,2)="ICD-9-CM"
SET IBDY9=1
if $PIECE(IBDX,U,2)="ICD-10-CM"
SET IBDY10=1
+27 ;Now compare with the user selection - ICD9/ICD10/Both/Neither
+28 IF IBDTAINS=9
IF IBDY9=0
QUIT
+29 IF IBDTAINS=10
IF IBDY10=0
QUIT
+30 IF IBDTAINS="B"
IF IBDY9=0!(IBDY10=0)
QUIT
+31 IF IBDTAINS="N"
IF IBDY9=1!(IBDY10=1)
QUIT
+32 ;Now find ICD-9/10 Status and history dates at the Selection level and update Latest Edit date where required
+33 KILL ^TMP("IBDFUTL4X",$JOB,"X","BLCODE")
+34 SET IBDLTSEL=""
FOR
SET IBDLTSEL=$ORDER(^IBE(357.3,"C",IBDLIST,IBDLTSEL))
if IBDLTSEL=""
QUIT
Begin DoDot:3
+35 SET IBDX=$GET(^IBE(357.3,IBDLTSEL,4))
+36 IF $PIECE(IBDX,U,1)>IBD9ED
SET IBD9ED=$PIECE(IBDX,U,1)
+37 IF $PIECE(IBDX,U,2)>IBD10ED
SET IBD10ED=$PIECE(IBDX,U,1)
+38 IF IBDINP("SD")="D"
Begin DoDot:4
+39 if IBDBLHD=""
SET IBDX=$ORDER(IBDDET(""),-1)+1
SET IBDDET(IBDX)="BL^"_IBDBLKNA
SET IBDBLHD=IBDBLKNA
+40 SET IBDX=^IBE(357.3,IBDLTSEL,0)
SET IBDDATA=$$ICDDATA^ICDXCODE(IBDSYS,$PIECE(IBDX,U,1))
SET IBDCODE=$PIECE(IBDX,U,1)
+41 IF '$DATA(^TMP("IBDFUTL4X",$JOB,"X","BLCODE",IBDCODE))
SET IBDSELX="LT^"_IBDLTSEL_U_IBDCODE_U_$PIECE(IBDDATA,U,4)
SET IBDX=$ORDER(IBDDET(""),-1)+1
SET IBDDET(IBDX)=IBDSELX
SET ^TMP("IBDFUTL4X",$JOB,"X","BLCODE",IBDCODE)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+42 ;We are now back at form level (357) and we know this form needs to be included in the list if user selection agrees
+43 SET IBDYES=1
Begin DoDot:1
+44 IF IBDTAINS=9&((IBDY9=0)!(IBDY10=1))
SET IBDYES=0
QUIT
+45 IF IBDTAINS=10&((IBDY9=1)!(IBDY10=0))
SET IBDYES=0
QUIT
+46 IF IBDTAINS="B"&((IBDY9=0)!(IBDY10=0))
SET IBDYES=0
QUIT
+47 IF IBDTAINS="N"&((IBDY9=1)!(IBDY10=1))
SET IBDYES=0
QUIT
End DoDot:1
+48 if IBDYES=0
QUIT
+49 SET IBDRES=""
+50 IF IBDY9=1
SET IBDRES="ICD9"
+51 IF IBDY10=1
Begin DoDot:1
+52 IF IBDY9=1
SET IBDRES="BOTH"
+53 IF '$TEST
SET IBDRES="ICD10"
End DoDot:1
+54 IF $EXTRACT(IBDSORT,2)="C"
SET IBDSUB=IBDCLNA
DO SET
+55 IF $EXTRACT(IBDSORT,2)="F"
SET IBDSUB=IBDFMNA
DO SET
+56 IF $EXTRACT(IBDSORT,2)="G"
SET IBDSUB=IBDGPNA
DO SET
+57 QUIT
+58 ;
SET ;
+1 NEW IBDY,IBD9DA,IBD10DA
+2 SET (IBD9DA,IBD10DA)=""
+3 IF IBD9ED>0
SET IBD9DA=$EXTRACT(IBD9ED,4,5)_"/"_$EXTRACT(IBD9ED,6,7)_"/"_$EXTRACT(IBD9ED,2,3)
+4 IF IBD10ED>0
SET IBD10DA=$EXTRACT(IBD10ED,4,5)_"/"_$EXTRACT(IBD10ED,6,7)_"/"_$EXTRACT(IBD10ED,2,3)
+5 SET IBDY=$SELECT(IBDFMSTA="":"",IBDFMSTA="C":"COMP",IBDFMSTA="I":"",IBDFMSTA="R":"REV",1:"")
+6 IF $EXTRACT(IBDSORT,2)'="G"
Begin DoDot:1
+7 SET @ARY@("S",IBDSUB,IBDFMNA)=IBDFMNA_U_IBDRES_U_IBD9DA_U_IBD10DA_U_IBDY_U_IBDCLNA_U_IBDCLIN_U_IBDFORM_U_$GET(IBDGPNA)
+8 IF IBDINP("SD")="D"
MERGE @ARY@("S",IBDSUB,IBDFMNA,"D")=IBDDET
End DoDot:1
+9 IF $EXTRACT(IBDSORT,2)="G"
Begin DoDot:1
+10 IF IBDGPNA=""
SET IBDGPNA="Unknown"
+11 SET @ARY@("S",IBDGPNA,IBDCLNA,IBDFMNA)=IBDFMNA_U_IBDRES_U_IBD9DA_U_IBD10DA_U_IBDY_U_IBDCLNA_U_IBDCLIN_U_IBDFORM_U_IBDGPNA
+12 IF IBDINP("SD")="D"
MERGE @ARY@("S",IBDGPNA,IBDCLNA,IBDFMNA,"D")=IBDDET
End DoDot:1
+13 QUIT
+14 ;
GRHEADNG(IBDGPNA,IBDCT) ;List each clinic under its grouped heading.
+1 NEW IBDX
+2 SET IBDX=""
SET IBDX=$$SETSTR^VALM1(" ",IBDX,1,3)
+3 SET ^TMP("IBDFUTL4",$JOB,IBDCT,0)=IBDX
+4 SET ^TMP("IBDFUTL4X",$JOB,"X","GPNA",IBDGPNA,IBDCT)=""
+5 SET IBDCT=IBDCT+1
SET VALMCNT=VALMCNT+1
+6 SET IBDVAL1=$LENGTH(IBDGPNA)
SET IBDVAL1=(80-IBDVAL1)/2
SET IBDVAL1=IBDVAL1\1
SET IBDX=""
SET IBDX=$$SETSTR^VALM1(" ",IBDX,1,IBDVAL1)
+7 SET IBDX=$$SETSTR^VALM1(IBDGPNA,IBDX,IBDVAL1,25)
+8 SET ^TMP("IBDFUTL4",$JOB,IBDCT,0)=IBDX
+9 SET ^TMP("IBDFUTL4X",$JOB,"X","GPNA",IBDGPNA,IBDCT)=""
+10 SET IBDCT=IBDCT+1
SET VALMCNT=VALMCNT+1
+11 DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
+12 SET IBDX=""
SET IBDX=$$SETSTR^VALM1(" ",IBDX,1,3)
+13 SET ^TMP("IBDFUTL4",$JOB,IBDCT,0)=IBDX
+14 SET ^TMP("IBDFUTL4X",$JOB,"X","GPNA",IBDGPNA,IBDCT)=""
+15 SET IBDCT=IBDCT+1
SET VALMCNT=VALMCNT+1
+16 QUIT
+17 ;
