IBDFUTL4 ;ALB/MKN/CFS - Maintenance Utility Encounter Forms ICD-10 Update ;12/29/2011
;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;;Build 80
;
;
N IBDARY,IBDX,IBDNA,IBDN,IBDN2,IBDBLK,IBDGPNA,IBDFM,IBDCT,IBDCT2,IBDS1,IBDS2,IBDS3,IBDFMNA,IBDCLNA,IBDCT
N IBDFL,IBDFSRT,IBDFDIS,IBDINP,IBDLI,IBDSTA,IBDJ,IBDW,IBDLINE,IBDN,IBDN1,IBDSC,IBDCL1,IBDCL2,IBDOUT,IBDQUIT
;
PROMPTS ;
S (IBDFL,VALMCNT)=0
K DIR S DIR("B")="CLINICS",DIR(0)="SA^C:CLINICS;G:GROUPS;F:FORMS",DIR("A")="Sort by [C]linics, [G]roups, [F]orms: " D ^DIR
K DIR I $D(DTOUT)!($D(DUOUT))!(Y=U) G:'$D(IBDRE) EXIT S VALMBCK="R",VALMBG=1 Q
S IBDX=$S("Gg"[X:2,"Ff"[X:3,"Ss"[X:4,1:1)
S IBDFSRT=$E(IBDX),IBDFDIS=$S(IBDFSRT=1:"CLINIC",IBDFSRT=2:"GROUP",IBDFSRT=3:"FORM",1:"QUIT")
S IBDX=$$SELASR() I 'IBDX S:$D(IBDRE) VALMBCK="R",VALMBG=1 Q:$D(IBDRE) G EXIT
;Coding Types
K DIR,DIC S DIR("B")="ALL",DIR(0)="S^9:ICD-9;10:ICD-10;B:Both;N:Neither;A:All"
S DIR("A")="Contains ICD-9 and/or ICD-10 diagnosis codes: "_$C(13,10)_" ICD-[9], ICD-[10], [B]oth, [N]either, [A]ll"
D ^DIR K DIR I ($D(DTOUT)!$D(DUOUT))!(Y=U) G:'$D(IBDRE) EXIT S VALMBCK="R",VALMBG=1 Q
S IBDINP("CONTAINS")=Y
;Update Status
K DIR S DIR("B")="ALL",DIR(0)="S^I:Incomplete;C:Complete;R:Review;A:All"
S DIR("A")="ICD-10 Update Status:"_$C(13,10)_" [I]ncomplete, [C]omplete, [R]eview, [A]ll"
D ^DIR K DIR I ($D(DTOUT)!$D(DUOUT))!(Y=U) G:'$D(IBDRE) EXIT S VALMBCK="R",VALMBG=1 Q
S IBDINP("STATUS")=Y
;Summary or Detail
K DIR S DIR("B")="SUMMARY",DIR(0)="S^S:Summary Report;D:Detail Report"
S DIR("A")="Report Type:"_$C(13,10)_" [S]ummary Report, [D]etail Report"
D ^DIR K DIR I ($D(DTOUT)!$D(DUOUT))!(Y=U) G:'$D(IBDRE) EXIT S VALMBCK="R",VALMBG=1 Q
S IBDINP("SD")=Y
I '$D(IBDRE) K XQORS,VALMEVL D EN^VALM("IBDF ICD10 STATUS REPORT")
I $D(IBDRE) D HDR,EXIT,INIT S VALMBCK="R",VALMBG=1
Q
;
SORT ;Set up sorted list
K ^TMP("IBDFUTL4",$J),^TMP("IBDFUTL4X",$J) S ^TMP("IBDFUTL4X",$J,"D",0)=0
S IBDARY="^TMP(""IBDFUTL4X"","_$J_")"
;Clinic Processing
I IBDINP("SORTBY")="AC" D G SETLIST
. S IBDSC=0 F S IBDSC=$O(^SC(IBDSC)) Q:IBDSC'?1.N D CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY)
I IBDINP("SORTBY")="SC" D G SETLIST
. S IBDX="" F S IBDX=$O(IBDINP("CLINIC",IBDX)) Q:IBDX="" S IBDSC=IBDINP("CLINIC",IBDX) D CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY)
I IBDINP("SORTBY")="RC" S IBDX=IBDINP("CLINIC","RC",1),IBDX=$O(^SC("B",IBDX),-1) D
. F S IBDX=$O(^SC("B",IBDX)) Q:IBDX=""!(IBDX]IBDINP("CLINIC","RC",2)) S IBDSC="" F S IBDSC=$O(^SC("B",IBDX,IBDSC)) Q:IBDSC'?1.N D
. . D CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY)
;Clinic Group Processing
I IBDINP("SORTBY")="AG" D G SETLIST
. S IBDX=0 F S IBDX=$O(^IBD(357.99,IBDX)) Q:IBDX'?1.N S IBDGPNA=$P($G(^IBD(357.99,IBDX,0)),U,1) S:IBDGPNA="" IBDGPNA="Unknown" D
. . S IBDN=0 F S IBDN=$O(^IBD(357.99,IBDX,10,IBDN)) Q:IBDN'?1.N S IBDSC=^IBD(357.99,IBDX,10,IBDN,0) D CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY,IBDGPNA)
I IBDINP("SORTBY")="SG" D G SETLIST
. S IBDX="" F S IBDX=$O(IBDINP("GROUP",IBDX)) Q:IBDX="" S IBDN=IBDINP("GROUP",IBDX),IBDGPNA=$P($G(^IBD(357.99,IBDN,0)),U,1) S:IBDGPNA="" IBDGPNA="Unknown" D
. . S IBDY=0 F S IBDY=$O(^IBD(357.99,IBDN,10,IBDY)) Q:IBDY'?1.N S IBDSC=^IBD(357.99,IBDN,10,IBDY,0) D CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY,IBDGPNA)
I IBDINP("SORTBY")="RG" S IBDX=IBDINP("GROUP","RG",1),IBDX=$O(^IBD(357.99,"B",IBDX),-1) D
. F S IBDX=$O(^IBD(357.99,"B",IBDX)) Q:IBDX=""!(IBDX]IBDINP("GROUP","RG",2)) D
. . S IBDIEN=$O(^IBD(357.99,"B",IBDX,""))
. . S IBDGPNA=$P($G(^IBD(357.99,IBDIEN,0)),U,1) S:IBDGPNA="" IBDGPNA="Unknown" D
. . . S IBDN=0 F S IBDN=$O(^IBD(357.99,IBDIEN,10,IBDN)) Q:IBDN'?1.N S IBDSC=^IBD(357.99,IBDIEN,10,IBDN,0) D CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY,IBDGPNA)
;Encounter Form Processing
I $E(IBDINP("SORTBY"),2)="F" D FMARR
I IBDINP("SORTBY")="AF" D G TOOLKITF
. S IBDSC=0 F S IBDSC=$O(^SC(IBDSC)) Q:IBDSC'?1.N D CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY)
I IBDINP("SORTBY")="SF" D G TOOLKITF
. S IBDFM="" F S IBDFM=$O(IBDINP("FORM",IBDFM)) Q:IBDFM="" D
. . S IBDSC="" F S IBDSC=$O(^TMP("IBDFUTL4X",$J,"X","FMARR",IBDFM,IBDSC)) Q:IBDSC="" D CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY)
I IBDINP("SORTBY")="RF" S IBDX=IBDINP("FORM","RF",1),IBDFM=$O(^TMP("IBDFUTL4X",$J,"X","FMARR",IBDX),-1) D
. F S IBDFM=$O(^TMP("IBDFUTL4X",$J,"X","FMARR",IBDFM)) Q:IBDFM=""!(IBDFM]IBDINP("FORM","RF",2)) S IBDSC="" D
. . F S IBDSC=$O(^TMP("IBDFUTL4X",$J,"X","FMARR",IBDFM,IBDSC)) Q:IBDSC="" D CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY)
TOOLKITF ;
I $E(IBDINP("SORTBY"),2)="F" S IBDFM="" F S IBDFM=$O(^TMP("IBDFUTL4X",$J,"X","FMTK",IBDFM)) Q:IBDFM="" D CHECKFM^IBDFUTL5(IBDFM,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY)
;
SETLIST ;Convert the list into Listman format
I $E(IBDINP("SORTBY"),2)'="G" D
. S IBDS1="",IBDCT=0 F S IBDS1=$O(^TMP("IBDFUTL4X",$J,"S",IBDS1)) Q:IBDS1="" D
. . S IBDS2="" F S IBDS2=$O(^TMP("IBDFUTL4X",$J,"S",IBDS1,IBDS2)) Q:IBDS2="" D
. . . S IBDCT=IBDCT+1 M ^TMP("IBDFUTL4X",$J,"D",IBDCT)=^TMP("IBDFUTL4X",$J,"S",IBDS1,IBDS2)
I $E(IBDINP("SORTBY"),2)="G" D
. S IBDS1="",IBDCT=0 F S IBDS1=$O(^TMP("IBDFUTL4X",$J,"S",IBDS1)) Q:IBDS1="" D
. . S IBDS2="" F S IBDS2=$O(^TMP("IBDFUTL4X",$J,"S",IBDS1,IBDS2)) Q:IBDS2="" D
. . . S IBDS3="" F S IBDS3=$O(^TMP("IBDFUTL4X",$J,"S",IBDS1,IBDS2,IBDS3)) Q:IBDS3="" D
. . . . S IBDCT=IBDCT+1 M ^TMP("IBDFUTL4X",$J,"D",IBDCT)=^TMP("IBDFUTL4X",$J,"S",IBDS1,IBDS2,IBDS3)
S ^TMP("IBDFUTL4X",$J,"D",0)=IBDCT
S IBDVAL=""
S (IBDN,VALMCNT,IBDCT)=0 F S IBDN=$O(^TMP("IBDFUTL4X",$J,"D",IBDN)) Q:IBDN="" S IBDX=^TMP("IBDFUTL4X",$J,"D",IBDN) D
. S IBDFM=$P(IBDX,U,8),IBDCT=IBDCT+1 ;,IBDLINE=$$SETSTR^VALM1(IBDN_")","",1,5),
. S IBDFMNA=$P(IBDX,U,1),IBDCLNA=$P(IBDX,U,6),IBDGPNA=$P(IBDX,U,9)
. I $E(IBDINP("SORTBY"),2)="G",IBDVAL'=IBDGPNA D GRHEADNG^IBDFUTL5(IBDGPNA,.IBDCT) ;List each clinic under its grouped heading. Grouped in ^IBD(357.99.
. S IBDLINE=$$SETSTR^VALM1(IBDN_")","",1,5)
. F IBDJ=1:1:6 S IBDW=$P("22/5/8/8/5/22","/",IBDJ) S IBDLINE=IBDLINE_$$SETSTR^VALM1($P(IBDX,U,IBDJ),"",1,IBDW)_" "
. S ^TMP("IBDFUTL4",$J,IBDCT,0)=IBDLINE,VALMCNT=IBDCT,^TMP("IBDFUTL4X",$J,"X","FM",IBDN)=IBDFM ; N=ROW IBDFM=Form IEN
. S ^TMP("IBDFUTL4X",$J,"X","ROW",IBDN)=IBDCT
. I $E(IBDINP("SORTBY"),2)="C" S ^TMP("IBDFUTL4X",$J,"X","CLNA",IBDCLNA,IBDCT)=""
. I $E(IBDINP("SORTBY"),2)="F" S ^TMP("IBDFUTL4X",$J,"X","FMNA",IBDFMNA,IBDCT)=""
. I $E(IBDINP("SORTBY"),2)="G" S ^TMP("IBDFUTL4X",$J,"X","GPNA",IBDGPNA,IBDCT)=""
. S IBDFMNA=$E(IBDFMNA,16,30),IBDCLNA=$E(IBDCLNA,13,24)
. S IBDVAL=IBDGPNA
. I IBDINP("SD")="D" S IBDN1=0 F S IBDN1=$O(^TMP("IBDFUTL4X",$J,"D",IBDN,"D",IBDN1)) Q:IBDN1="" S IBDX=^TMP("IBDFUTL4X",$J,"D",IBDN,"D",IBDN1) D
. . I $P(IBDX,U,1)="BL" S IBDLINE=" Block: "_$E($P(IBDX,U,2),1,30)
. . I $P(IBDX,U,1)="LT" S IBDLINE=" "_$E($P(IBDX,U,3),1,8)_$J(" ",8-$L($E($P(IBDX,U,3),1,8)))_" "_$P(IBDX,U,4)
. . S IBDCT=IBDCT+1,^TMP("IBDFUTL4",$J,IBDCT,0)=IBDLINE,VALMCNT=IBDCT
Q
;
FMARR ;Set up FORMARR(FORMNAME,CLINIC)
N IBDFM,IBDCL,IBDFT,IBDX,IBDI,IBDFMX,IBDFMNA,IBDFMSTA,IBDQUIT,IBDFM
S IBDCL=0 F S IBDCL=$O(^SD(409.95,"B",IBDCL)) Q:IBDCL'?1.N S IBDFT="" F S IBDFT=$O(^SD(409.95,"B",IBDCL,IBDFT)) Q:IBDFT="" D
. S IBDX=^SD(409.95,IBDFT,0) ; FORM LIST
. F IBDI=2:1:9 S IBDFM=$P(IBDX,U,IBDI) I IBDFM?1.N S IBDFMX=$G(^IBE(357,IBDFM,0)),IBDFMNA=$P(IBDFMX,U,1),IBDFMSTA=$E($P(IBDFMX,U,18)) S:IBDFMNA="" IBDFMNA="Unknown" D I 'IBDQUIT S ^TMP("IBDFUTL4X",$J,"X","FMARR",IBDFMNA,IBDCL)=IBDFM_U_IBDFMSTA
. . 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
. . S IBDQUIT=0
S IBDFM=0 F S IBDFM=$O(^IBE(357,IBDFM)) Q:IBDFM'?1.N S IBDX=$G(^IBE(357,IBDFM,0)),IBDFMNA=$P(IBDX,U,1) I IBDFMNA'="" I '$D(^TMP("IBDFUTL4X",$J,"X","FMARR",IBDFMNA)) S ^TMP("IBDFUTL4X",$J,"X","FMTK",IBDFM)=""
Q
;
EXIT ; -- Code executed at action exit
K IBDARY,IBDX,IBDNA,IBDN,IBDN2,IBDBLK,IBDGPNA,IBDFM,IBDCT,IBDS1,IBDS2,IBDFMNA,IBDCLNA,IBDCT,IBDRE
K ^TMP("IBDFUTL4",$J),^TMP("IBDFUTL4X",$J)
Q
;
SELASR() ;Ask for All, Selected or Range
K DIR
I IBDFDIS="CLINIC" S DIR("B")="ALL CLINICS",DIR(0)="S^AC:ALL CLINICS;SC:SELECTED CLINICS;RC:RANGE OF CLINICS",DIR("A")="Selection type"
I IBDFDIS="GROUP" S DIR("B")="ALL CLINIC GROUPS",DIR(0)="S^AG:ALL CLINIC GROUPS;SG:SELECTED CLINIC GROUPS;RG:RANGE OF CLINIC GROUPS",DIR("A")="Selection type"
I IBDFDIS="FORM" S DIR("B")="ALL ENCOUNTER FORMS",DIR(0)="S^AF:ALL ENCOUNTER FORMS;SF:SELECTED ENCOUNTER FORMS;RF:RANGE OF ENCOUNTER FORMS",DIR("A")="Selection type"
D ^DIR Q:$D(DTOUT)!$D(DUOUT) 0 S IBDINP("SORTBY")=Y
K IBDINP("CLINIC") I "SC^RC"[IBDINP("SORTBY") D @IBDINP("SORTBY") Q:'$D(IBDINP("CLINIC")) 0
K IBDINP("GROUP") I "SG^RG"[IBDINP("SORTBY") D @IBDINP("SORTBY") Q:'$D(IBDINP("GROUP")) 0
K IBDINP("FORM") I "SF^RF"[IBDINP("SORTBY") D @IBDINP("SORTBY") Q:'$D(IBDINP("FORM")) 0
Q 1
;
SC ;Clinic selector
N IBDI
S IBDOUT=0 F IBDI=1:1:30 S IBDCL1=$$SC1("Select CLINIC: ") Q:IBDOUT
Q
;
SC1(IBDICA) ;Select a clinic
SC2 K DIC S DIC("A")=IBDICA,DIC="^SC(",DIC(0)="AEMQZN",DIC("S")="I $P(^(0),U,3)=""C""" D ^DIC I $D(DTOUT)!$D(DUOUT)!(X="") S IBDOUT=1 Q ""
S IBDINP("CLINIC",$P(Y,U,2))=$P(Y,U)
Q $P(Y,U,2)
;
RC ;Clinic range selector
S IBDCL1=$$SC1("Select beginning CLINIC: ") Q:'$L(IBDCL1)
RCE S IBDCL2=$$SC1("Select ending CLINIC: ") I '$L(IBDCL2) W !,"Ending clinic must be specified!" K IBDINP("CLINIC") Q
I IBDCL1]IBDCL2 K IBDINP("CLINIC",IBDCL2) W !!,$C(7),"Ending clinic must collate after beginning clinic!" G RCE
S IBDINP("CLINIC","RC",1)=IBDCL1,IBDINP("CLINIC","RC",2)=IBDCL2
Q
;
SG ;Clinic GROUP selector
N IBDI
S IBDOUT=0 F IBDI=1:1:30 S IBDCL1=$$SG1("Select Clinic GROUP: ") Q:IBDOUT
Q
;
SG1(IBDICA) ;Select a clinic GROUP
SG2 ;
K DIC S DIC("A")=IBDICA,DIC="^IBD(357.99,",DIC(0)="AEMQZ" D ^DIC I $D(DTOUT)!$D(DUOUT)!(X="") S IBDOUT=1 Q ""
S IBDINP("GROUP",$P(Y,U,2))=$P(Y,U)
Q $P(Y,U,2)
;
RG ;Clinic range selector
S IBDCL1=$$SG1("Select beginning Clinic GROUP: ") Q:'$L(IBDCL1)
RGE S IBDCL2=$$SG1("Select ending Clinic GROUP: ") I '$L(IBDCL2) W !,"Ending clinic group must be specified!" K IBDINP("GROUP") Q
I IBDCL1]IBDCL2 K IBDINP("GROUP",IBDCL2) W !!,$C(7),"Ending clinic group must collate after beginning clinic!" G RGE
S IBDINP("GROUP","RG",1)=IBDCL1,IBDINP("GROUP","RG",2)=IBDCL2
Q
;
SF ;Encounter Form selector
N IBDI
S IBDOUT=0 F IBDI=1:1:30 S IBDCL1=$$SF1("Select Encounter Form: ") Q:IBDOUT
Q
;
SF1(IBDICA) ;Select an Encounter Form
SF2 K DIC S DIC("A")=IBDICA,DIC="^IBE(357,",DIC(0)="AEMQZ" D ^DIC I $D(DTOUT)!$D(DUOUT)!(X="") S IBDOUT=1 Q ""
S IBDINP("FORM",$P(Y,U,2))=$P(Y,U)
Q $P(Y,U,2)
;
RF ;Clinic range selector
S IBDCL1=$$SF1("Select beginning Encounter Form: ") Q:'$L(IBDCL1)
RFE S IBDCL2=$$SF1("Select ending Encounter Form: ") I '$L(IBDCL2) W !,"Ending Encounter Form must be specified!" K IBDINP("FORM") Q
I IBDCL1]IBDCL2 K IBDINP("FORM",IBDCL2) W !!,$C(7),"Ending Encounter Form must collate after Encounter Form!" G RFE
S IBDINP("FORM","RF",1)=IBDCL1,IBDINP("FORM","RF",2)=IBDCL2
Q
;
HDR ; -- header code
S VALMHDR(1)=" ENCOUNTER FORM ICD9/ LAST EDITED ICD10 CLINIC"
S VALMHDR(2)=" ICD10 ICD9 ICD10 STATUS "
Q
;
INIT ;
D FULL^VALM1 D KILL^VALM10()
K ^TMP("IBDFUTL4",$J),^TMP("IBDFUTL4X",$J)
D SORT
I '$D(^TMP("IBDFUTL4",$J)) S ^TMP("IBDFUTL4",$J,1,0)=" ",^TMP("IBDFUTL4",$J,2,0)="No records found"
Q
;
HELP ;
S X="?" D DISP^XQORM1 W !!
Q
;
CL ;
D FULL^VALM1 S IBDRE=1
D PROMPTS
Q
;
JP ;
N IBDI,IBDX,IBDY,IBDARR,IBDSB,IBDQUIT,IBDL,IBDRES,IBDN
D FULL^VALM1
JMP ;
S DIC=$S($E(IBDINP("SORTBY"),2)="F":"^IBE(357,",$E(IBDINP("SORTBY"),2)="G":"^IBD(357.99,",1:"^SC(")
S DIC(0)="AEMN",DIC("A")="Select the "_$S($E(IBDINP("SORTBY"),2)="F":"Encounter Form",$E(IBDINP("SORTBY"),2)="G":"Clinic Group",1:"Clinic")_" that you wish to move to: "
S:$E(IBDINP("SORTBY"),2)="C" DIC("S")="I $P(^SC(+Y,0),U,3)=""C"""
D ^DIC K DIC
I X["^" S VALMBG=1,VALMBCK="R" Q
I Y<0 G JP
S IBDX=$S($E(IBDINP("SORTBY"),2)="F":$P(^IBE(357,+Y,0),"^",1),$E(IBDINP("SORTBY"),2)="G":$P(^IBD(357.99,+Y,0),"^",1),1:$P(^SC(+Y,0),"^",1))
I '$D(IBDX) W !!,"There is no data listed for this Clinic Group" G JMP
I $E(IBDINP("SORTBY"),2)="C" S IBDSB="CLNA"
I $E(IBDINP("SORTBY"),2)="F" S IBDSB="FMNA"
I $E(IBDINP("SORTBY"),2)="G" S IBDSB="GPNA"
S IBDY=$O(^TMP("IBDFUTL4X",$J,"X",IBDSB,IBDX),-1),(IBDI,IBDQUIT,IBDL)=0,IBDRES="" K IBDARR
F S IBDY=$O(^TMP("IBDFUTL4X",$J,"X",IBDSB,IBDY)) Q:IBDY=""!($E(IBDY,1,$L(IBDX))'=IBDX) D
. S IBDI=IBDI+1,IBDARR(IBDI)=IBDY
I IBDI=1 S IBDRES=IBDARR(1) G JP5
S IBDN="",IBDI=0 F S IBDN=$O(IBDARR(IBDN)) Q:IBDN="" S IBDI=IBDI+1 W !,IBDN,". ",IBDARR(IBDN) D Q:IBDQUIT!(IBDRES'="")
. I '(IBDI#5) S IBDL=IBDI D JPDIS S:$D(DTOUT)!($D(DUOUT))!(Y=U) IBDQUIT=1 Q:IBDQUIT D Q:IBDRES'=""
. . S Y=+Y I Y>0 S IBDRES=IBDARR(Y)
I IBDQUIT S VALMBCK="R" Q
I IBDRES="",IBDI>IBDL D JPDIS Q:$D(DTOUT)!($D(DUOUT))!(Y=U) S Y=+Y I Y>0 S IBDRES=IBDARR(Y)
I IBDRES="" S VALMBCK="R" Q
JP5 ;
S IBDROW=$O(^TMP("IBDFUTL4X",$J,"X",IBDSB,IBDRES,""))
S VALMBG=IBDROW,VALMBCK="R"
;
Q
;
JPDIS ;
W !,"Press <RETURN> to see more, '^' to exit this list, OR"
S DIR(0)="NO^1:"_IBDI,DIR("A")="Choose 1-"_IBDI D ^DIR
Q
;
IS ;UPDATE ICD10 STATUS FIELD
N IBDI,IBDX,IBDY,IBDFM,IBDN,IBDQUIT,IBDPR,IBDROW,IBDSTA
I '$D(^TMP("IBDFUTL4X",$J,"D",0)) S VALMBCK="R" Q
K DIR S DIR(0)="L^1:"_^TMP("IBDFUTL4X",$J,"D",0) D ^DIR
I $D(DTOUT)!($D(DUOUT))!(Y=U) S VALMBCK="R" Q
S IBDY=Y,(IBDQUIT,IBDROW)=0 F IBDI=1:1:$L(Y,",") S IBDLI=$P(IBDY,",",IBDI) I IBDLI?1.N S:IBDROW=0 IBDROW=IBDLI D Q:IBDQUIT
. S IBDFM=$G(^TMP("IBDFUTL4X",$J,"X","FM",IBDLI)) Q:IBDFM'?1.N
. S IBDX=$G(^IBE(357,IBDFM,0)) Q:IBDX="" W !,"Encounter Form: ",$P(IBDX,U,1)
. S IBDSTA="",IBDN=$O(^IBE(357,IBDFM,3,"B",30,"")) I IBDN?1.N S IBDX=^IBE(357,IBDFM,3,IBDN,0),IBDSTA=$P(IBDX,U,2)
. K DIR D
. . I IBDSTA="" S IBDPR="Update Status to [C]omplete or [R]eview",DIR(0)="S^C:Complete;R:Review",DIR("B")="Complete"
. . I IBDSTA="C" S IBDPR="Update Status to [I]ncomplete or [R]eview",DIR(0)="S^I:Incomplete;R:Review",DIR("B")="Incomplete"
. . I IBDSTA="R" S IBDPR="Update Status to [C]omplete or [I]ncomplete",DIR(0)="S^C:Complete;I:Incomplete",DIR("B")="Complete"
. S DIR("A")=IBDPR D ^DIR K DIR I ($D(DTOUT)!$D(DUOUT)) S IBDQUIT=1 Q
. S IBDPR="Are you changing the Status from "_$S(IBDSTA="":"Incomplete",IBDSTA="C":"Complete",1:"Review")_" to "_$S(Y="I":"Incomplete",Y="C":"Complete",1:"Review")
. S IBDX=$$YESNO^IBDUTIL1(IBDPR,"Y",0,300)
. I IBDX=1 S IBDX=$$YESNO^IBDUTIL1("Are you sure you want to change the status","NO",0,300)
. I IBDX=1 S:Y="I" Y="@" S IBDX=$$CSUPD357^IBDUTICD(IBDFM,30,Y,$$NOW^XLFDT(),DUZ)
D SORT
S VALMBCK="R"
Q
;
EXP ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFUTL4 15284 printed Oct 16, 2024@18:54:37 Page 2
IBDFUTL4 ;ALB/MKN/CFS - Maintenance Utility Encounter Forms ICD-10 Update ;12/29/2011
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;;Build 80
+2 ;
+3 ;
+4 NEW IBDARY,IBDX,IBDNA,IBDN,IBDN2,IBDBLK,IBDGPNA,IBDFM,IBDCT,IBDCT2,IBDS1,IBDS2,IBDS3,IBDFMNA,IBDCLNA,IBDCT
+5 NEW IBDFL,IBDFSRT,IBDFDIS,IBDINP,IBDLI,IBDSTA,IBDJ,IBDW,IBDLINE,IBDN,IBDN1,IBDSC,IBDCL1,IBDCL2,IBDOUT,IBDQUIT
+6 ;
PROMPTS ;
+1 SET (IBDFL,VALMCNT)=0
+2 KILL DIR
SET DIR("B")="CLINICS"
SET DIR(0)="SA^C:CLINICS;G:GROUPS;F:FORMS"
SET DIR("A")="Sort by [C]linics, [G]roups, [F]orms: "
DO ^DIR
+3 KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!(Y=U)
if '$DATA(IBDRE)
GOTO EXIT
SET VALMBCK="R"
SET VALMBG=1
QUIT
+4 SET IBDX=$SELECT("Gg"[X:2,"Ff"[X:3,"Ss"[X:4,1:1)
+5 SET IBDFSRT=$EXTRACT(IBDX)
SET IBDFDIS=$SELECT(IBDFSRT=1:"CLINIC",IBDFSRT=2:"GROUP",IBDFSRT=3:"FORM",1:"QUIT")
+6 SET IBDX=$$SELASR()
IF 'IBDX
if $DATA(IBDRE)
SET VALMBCK="R"
SET VALMBG=1
if $DATA(IBDRE)
QUIT
GOTO EXIT
+7 ;Coding Types
+8 KILL DIR,DIC
SET DIR("B")="ALL"
SET DIR(0)="S^9:ICD-9;10:ICD-10;B:Both;N:Neither;A:All"
+9 SET DIR("A")="Contains ICD-9 and/or ICD-10 diagnosis codes: "_$CHAR(13,10)_" ICD-[9], ICD-[10], [B]oth, [N]either, [A]ll"
+10 DO ^DIR
KILL DIR
IF ($DATA(DTOUT)!$DATA(DUOUT))!(Y=U)
if '$DATA(IBDRE)
GOTO EXIT
SET VALMBCK="R"
SET VALMBG=1
QUIT
+11 SET IBDINP("CONTAINS")=Y
+12 ;Update Status
+13 KILL DIR
SET DIR("B")="ALL"
SET DIR(0)="S^I:Incomplete;C:Complete;R:Review;A:All"
+14 SET DIR("A")="ICD-10 Update Status:"_$CHAR(13,10)_" [I]ncomplete, [C]omplete, [R]eview, [A]ll"
+15 DO ^DIR
KILL DIR
IF ($DATA(DTOUT)!$DATA(DUOUT))!(Y=U)
if '$DATA(IBDRE)
GOTO EXIT
SET VALMBCK="R"
SET VALMBG=1
QUIT
+16 SET IBDINP("STATUS")=Y
+17 ;Summary or Detail
+18 KILL DIR
SET DIR("B")="SUMMARY"
SET DIR(0)="S^S:Summary Report;D:Detail Report"
+19 SET DIR("A")="Report Type:"_$CHAR(13,10)_" [S]ummary Report, [D]etail Report"
+20 DO ^DIR
KILL DIR
IF ($DATA(DTOUT)!$DATA(DUOUT))!(Y=U)
if '$DATA(IBDRE)
GOTO EXIT
SET VALMBCK="R"
SET VALMBG=1
QUIT
+21 SET IBDINP("SD")=Y
+22 IF '$DATA(IBDRE)
KILL XQORS,VALMEVL
DO EN^VALM("IBDF ICD10 STATUS REPORT")
+23 IF $DATA(IBDRE)
DO HDR
DO EXIT
DO INIT
SET VALMBCK="R"
SET VALMBG=1
+24 QUIT
+25 ;
SORT ;Set up sorted list
+1 KILL ^TMP("IBDFUTL4",$JOB),^TMP("IBDFUTL4X",$JOB)
SET ^TMP("IBDFUTL4X",$JOB,"D",0)=0
+2 SET IBDARY="^TMP(""IBDFUTL4X"","_$JOB_")"
+3 ;Clinic Processing
+4 IF IBDINP("SORTBY")="AC"
Begin DoDot:1
+5 SET IBDSC=0
FOR
SET IBDSC=$ORDER(^SC(IBDSC))
if IBDSC'?1.N
QUIT
DO CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY)
End DoDot:1
GOTO SETLIST
+6 IF IBDINP("SORTBY")="SC"
Begin DoDot:1
+7 SET IBDX=""
FOR
SET IBDX=$ORDER(IBDINP("CLINIC",IBDX))
if IBDX=""
QUIT
SET IBDSC=IBDINP("CLINIC",IBDX)
DO CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY)
End DoDot:1
GOTO SETLIST
+8 IF IBDINP("SORTBY")="RC"
SET IBDX=IBDINP("CLINIC","RC",1)
SET IBDX=$ORDER(^SC("B",IBDX),-1)
Begin DoDot:1
+9 FOR
SET IBDX=$ORDER(^SC("B",IBDX))
if IBDX=""!(IBDX]IBDINP("CLINIC","RC",2))
QUIT
SET IBDSC=""
FOR
SET IBDSC=$ORDER(^SC("B",IBDX,IBDSC))
if IBDSC'?1.N
QUIT
Begin DoDot:2
+10 DO CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY)
End DoDot:2
End DoDot:1
+11 ;Clinic Group Processing
+12 IF IBDINP("SORTBY")="AG"
Begin DoDot:1
+13 SET IBDX=0
FOR
SET IBDX=$ORDER(^IBD(357.99,IBDX))
if IBDX'?1.N
QUIT
SET IBDGPNA=$PIECE($GET(^IBD(357.99,IBDX,0)),U,1)
if IBDGPNA=""
SET IBDGPNA="Unknown"
Begin DoDot:2
+14 SET IBDN=0
FOR
SET IBDN=$ORDER(^IBD(357.99,IBDX,10,IBDN))
if IBDN'?1.N
QUIT
SET IBDSC=^IBD(357.99,IBDX,10,IBDN,0)
DO CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY,IBDGPNA)
End DoDot:2
End DoDot:1
GOTO SETLIST
+15 IF IBDINP("SORTBY")="SG"
Begin DoDot:1
+16 SET IBDX=""
FOR
SET IBDX=$ORDER(IBDINP("GROUP",IBDX))
if IBDX=""
QUIT
SET IBDN=IBDINP("GROUP",IBDX)
SET IBDGPNA=$PIECE($GET(^IBD(357.99,IBDN,0)),U,1)
if IBDGPNA=""
SET IBDGPNA="Unknown"
Begin DoDot:2
+17 SET IBDY=0
FOR
SET IBDY=$ORDER(^IBD(357.99,IBDN,10,IBDY))
if IBDY'?1.N
QUIT
SET IBDSC=^IBD(357.99,IBDN,10,IBDY,0)
DO CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY,IBDGPNA)
End DoDot:2
End DoDot:1
GOTO SETLIST
+18 IF IBDINP("SORTBY")="RG"
SET IBDX=IBDINP("GROUP","RG",1)
SET IBDX=$ORDER(^IBD(357.99,"B",IBDX),-1)
Begin DoDot:1
+19 FOR
SET IBDX=$ORDER(^IBD(357.99,"B",IBDX))
if IBDX=""!(IBDX]IBDINP("GROUP","RG",2))
QUIT
Begin DoDot:2
+20 SET IBDIEN=$ORDER(^IBD(357.99,"B",IBDX,""))
+21 SET IBDGPNA=$PIECE($GET(^IBD(357.99,IBDIEN,0)),U,1)
if IBDGPNA=""
SET IBDGPNA="Unknown"
Begin DoDot:3
+22 SET IBDN=0
FOR
SET IBDN=$ORDER(^IBD(357.99,IBDIEN,10,IBDN))
if IBDN'?1.N
QUIT
SET IBDSC=^IBD(357.99,IBDIEN,10,IBDN,0)
DO CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY,IBDGPNA)
End DoDot:3
End DoDot:2
End DoDot:1
+23 ;Encounter Form Processing
+24 IF $EXTRACT(IBDINP("SORTBY"),2)="F"
DO FMARR
+25 IF IBDINP("SORTBY")="AF"
Begin DoDot:1
+26 SET IBDSC=0
FOR
SET IBDSC=$ORDER(^SC(IBDSC))
if IBDSC'?1.N
QUIT
DO CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY)
End DoDot:1
GOTO TOOLKITF
+27 IF IBDINP("SORTBY")="SF"
Begin DoDot:1
+28 SET IBDFM=""
FOR
SET IBDFM=$ORDER(IBDINP("FORM",IBDFM))
if IBDFM=""
QUIT
Begin DoDot:2
+29 SET IBDSC=""
FOR
SET IBDSC=$ORDER(^TMP("IBDFUTL4X",$JOB,"X","FMARR",IBDFM,IBDSC))
if IBDSC=""
QUIT
DO CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY)
End DoDot:2
End DoDot:1
GOTO TOOLKITF
+30 IF IBDINP("SORTBY")="RF"
SET IBDX=IBDINP("FORM","RF",1)
SET IBDFM=$ORDER(^TMP("IBDFUTL4X",$JOB,"X","FMARR",IBDX),-1)
Begin DoDot:1
+31 FOR
SET IBDFM=$ORDER(^TMP("IBDFUTL4X",$JOB,"X","FMARR",IBDFM))
if IBDFM=""!(IBDFM]IBDINP("FORM","RF",2))
QUIT
SET IBDSC=""
Begin DoDot:2
+32 FOR
SET IBDSC=$ORDER(^TMP("IBDFUTL4X",$JOB,"X","FMARR",IBDFM,IBDSC))
if IBDSC=""
QUIT
DO CHECKCL^IBDFUTL5(IBDSC,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY)
End DoDot:2
End DoDot:1
TOOLKITF ;
+1 IF $EXTRACT(IBDINP("SORTBY"),2)="F"
SET IBDFM=""
FOR
SET IBDFM=$ORDER(^TMP("IBDFUTL4X",$JOB,"X","FMTK",IBDFM))
if IBDFM=""
QUIT
DO CHECKFM^IBDFUTL5(IBDFM,IBDINP("CONTAINS"),IBDINP("SORTBY"),IBDARY)
+2 ;
SETLIST ;Convert the list into Listman format
+1 IF $EXTRACT(IBDINP("SORTBY"),2)'="G"
Begin DoDot:1
+2 SET IBDS1=""
SET IBDCT=0
FOR
SET IBDS1=$ORDER(^TMP("IBDFUTL4X",$JOB,"S",IBDS1))
if IBDS1=""
QUIT
Begin DoDot:2
+3 SET IBDS2=""
FOR
SET IBDS2=$ORDER(^TMP("IBDFUTL4X",$JOB,"S",IBDS1,IBDS2))
if IBDS2=""
QUIT
Begin DoDot:3
+4 SET IBDCT=IBDCT+1
MERGE ^TMP("IBDFUTL4X",$JOB,"D",IBDCT)=^TMP("IBDFUTL4X",$JOB,"S",IBDS1,IBDS2)
End DoDot:3
End DoDot:2
End DoDot:1
+5 IF $EXTRACT(IBDINP("SORTBY"),2)="G"
Begin DoDot:1
+6 SET IBDS1=""
SET IBDCT=0
FOR
SET IBDS1=$ORDER(^TMP("IBDFUTL4X",$JOB,"S",IBDS1))
if IBDS1=""
QUIT
Begin DoDot:2
+7 SET IBDS2=""
FOR
SET IBDS2=$ORDER(^TMP("IBDFUTL4X",$JOB,"S",IBDS1,IBDS2))
if IBDS2=""
QUIT
Begin DoDot:3
+8 SET IBDS3=""
FOR
SET IBDS3=$ORDER(^TMP("IBDFUTL4X",$JOB,"S",IBDS1,IBDS2,IBDS3))
if IBDS3=""
QUIT
Begin DoDot:4
+9 SET IBDCT=IBDCT+1
MERGE ^TMP("IBDFUTL4X",$JOB,"D",IBDCT)=^TMP("IBDFUTL4X",$JOB,"S",IBDS1,IBDS2,IBDS3)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+10 SET ^TMP("IBDFUTL4X",$JOB,"D",0)=IBDCT
+11 SET IBDVAL=""
+12 SET (IBDN,VALMCNT,IBDCT)=0
FOR
SET IBDN=$ORDER(^TMP("IBDFUTL4X",$JOB,"D",IBDN))
if IBDN=""
QUIT
SET IBDX=^TMP("IBDFUTL4X",$JOB,"D",IBDN)
Begin DoDot:1
+13 ;,IBDLINE=$$SETSTR^VALM1(IBDN_")","",1,5),
SET IBDFM=$PIECE(IBDX,U,8)
SET IBDCT=IBDCT+1
+14 SET IBDFMNA=$PIECE(IBDX,U,1)
SET IBDCLNA=$PIECE(IBDX,U,6)
SET IBDGPNA=$PIECE(IBDX,U,9)
+15 ;List each clinic under its grouped heading. Grouped in ^IBD(357.99.
IF $EXTRACT(IBDINP("SORTBY"),2)="G"
IF IBDVAL'=IBDGPNA
DO GRHEADNG^IBDFUTL5(IBDGPNA,.IBDCT)
+16 SET IBDLINE=$$SETSTR^VALM1(IBDN_")","",1,5)
+17 FOR IBDJ=1:1:6
SET IBDW=$PIECE("22/5/8/8/5/22","/",IBDJ)
SET IBDLINE=IBDLINE_$$SETSTR^VALM1($PIECE(IBDX,U,IBDJ),"",1,IBDW)_" "
+18 ; N=ROW IBDFM=Form IEN
SET ^TMP("IBDFUTL4",$JOB,IBDCT,0)=IBDLINE
SET VALMCNT=IBDCT
SET ^TMP("IBDFUTL4X",$JOB,"X","FM",IBDN)=IBDFM
+19 SET ^TMP("IBDFUTL4X",$JOB,"X","ROW",IBDN)=IBDCT
+20 IF $EXTRACT(IBDINP("SORTBY"),2)="C"
SET ^TMP("IBDFUTL4X",$JOB,"X","CLNA",IBDCLNA,IBDCT)=""
+21 IF $EXTRACT(IBDINP("SORTBY"),2)="F"
SET ^TMP("IBDFUTL4X",$JOB,"X","FMNA",IBDFMNA,IBDCT)=""
+22 IF $EXTRACT(IBDINP("SORTBY"),2)="G"
SET ^TMP("IBDFUTL4X",$JOB,"X","GPNA",IBDGPNA,IBDCT)=""
+23 SET IBDFMNA=$EXTRACT(IBDFMNA,16,30)
SET IBDCLNA=$EXTRACT(IBDCLNA,13,24)
+24 SET IBDVAL=IBDGPNA
+25 IF IBDINP("SD")="D"
SET IBDN1=0
FOR
SET IBDN1=$ORDER(^TMP("IBDFUTL4X",$JOB,"D",IBDN,"D",IBDN1))
if IBDN1=""
QUIT
SET IBDX=^TMP("IBDFUTL4X",$JOB,"D",IBDN,"D",IBDN1)
Begin DoDot:2
+26 IF $PIECE(IBDX,U,1)="BL"
SET IBDLINE=" Block: "_$EXTRACT($PIECE(IBDX,U,2),1,30)
+27 IF $PIECE(IBDX,U,1)="LT"
SET IBDLINE=" "_$EXTRACT($PIECE(IBDX,U,3),1,8)_$JUSTIFY(" ",8-$LENGTH($EXTRACT($PIECE(IBDX,U,3),1,8)))_" "_$PIECE(IBDX,U,4)
+28 SET IBDCT=IBDCT+1
SET ^TMP("IBDFUTL4",$JOB,IBDCT,0)=IBDLINE
SET VALMCNT=IBDCT
End DoDot:2
End DoDot:1
+29 QUIT
+30 ;
FMARR ;Set up FORMARR(FORMNAME,CLINIC)
+1 NEW IBDFM,IBDCL,IBDFT,IBDX,IBDI,IBDFMX,IBDFMNA,IBDFMSTA,IBDQUIT,IBDFM
+2 SET IBDCL=0
FOR
SET IBDCL=$ORDER(^SD(409.95,"B",IBDCL))
if IBDCL'?1.N
QUIT
SET IBDFT=""
FOR
SET IBDFT=$ORDER(^SD(409.95,"B",IBDCL,IBDFT))
if IBDFT=""
QUIT
Begin DoDot:1
+3 ; FORM LIST
SET IBDX=^SD(409.95,IBDFT,0)
+4 FOR IBDI=2:1:9
SET IBDFM=$PIECE(IBDX,U,IBDI)
IF IBDFM?1.N
SET IBDFMX=$GET(^IBE(357,IBDFM,0))
SET IBDFMNA=$PIECE(IBDFMX,U,1)
SET IBDFMSTA=$EXTRACT($PIECE(IBDFMX,U,18))
if IBDFMNA=""
SET IBDFMNA="Unknown"
Begin DoDot:2
+5 IF IBDINP("STATUS")="I"
IF IBDFMSTA'=""
SET IBDQUIT=1
QUIT
+6 IF IBDINP("STATUS")="C"
IF IBDFMSTA'="C"
SET IBDQUIT=1
QUIT
+7 IF IBDINP("STATUS")="R"
IF IBDFMSTA'="R"
SET IBDQUIT=1
QUIT
+8 SET IBDQUIT=0
End DoDot:2
IF 'IBDQUIT
SET ^TMP("IBDFUTL4X",$JOB,"X","FMARR",IBDFMNA,IBDCL)=IBDFM_U_IBDFMSTA
End DoDot:1
+9 SET IBDFM=0
FOR
SET IBDFM=$ORDER(^IBE(357,IBDFM))
if IBDFM'?1.N
QUIT
SET IBDX=$GET(^IBE(357,IBDFM,0))
SET IBDFMNA=$PIECE(IBDX,U,1)
IF IBDFMNA'=""
IF '$DATA(^TMP("IBDFUTL4X",$JOB,"X","FMARR",IBDFMNA))
SET ^TMP("IBDFUTL4X",$JOB,"X","FMTK",IBDFM)=""
+10 QUIT
+11 ;
EXIT ; -- Code executed at action exit
+1 KILL IBDARY,IBDX,IBDNA,IBDN,IBDN2,IBDBLK,IBDGPNA,IBDFM,IBDCT,IBDS1,IBDS2,IBDFMNA,IBDCLNA,IBDCT,IBDRE
+2 KILL ^TMP("IBDFUTL4",$JOB),^TMP("IBDFUTL4X",$JOB)
+3 QUIT
+4 ;
SELASR() ;Ask for All, Selected or Range
+1 KILL DIR
+2 IF IBDFDIS="CLINIC"
SET DIR("B")="ALL CLINICS"
SET DIR(0)="S^AC:ALL CLINICS;SC:SELECTED CLINICS;RC:RANGE OF CLINICS"
SET DIR("A")="Selection type"
+3 IF IBDFDIS="GROUP"
SET DIR("B")="ALL CLINIC GROUPS"
SET DIR(0)="S^AG:ALL CLINIC GROUPS;SG:SELECTED CLINIC GROUPS;RG:RANGE OF CLINIC GROUPS"
SET DIR("A")="Selection type"
+4 IF IBDFDIS="FORM"
SET DIR("B")="ALL ENCOUNTER FORMS"
SET DIR(0)="S^AF:ALL ENCOUNTER FORMS;SF:SELECTED ENCOUNTER FORMS;RF:RANGE OF ENCOUNTER FORMS"
SET DIR("A")="Selection type"
+5 DO ^DIR
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT 0
SET IBDINP("SORTBY")=Y
+6 KILL IBDINP("CLINIC")
IF "SC^RC"[IBDINP("SORTBY")
DO @IBDINP("SORTBY")
if '$DATA(IBDINP("CLINIC"))
QUIT 0
+7 KILL IBDINP("GROUP")
IF "SG^RG"[IBDINP("SORTBY")
DO @IBDINP("SORTBY")
if '$DATA(IBDINP("GROUP"))
QUIT 0
+8 KILL IBDINP("FORM")
IF "SF^RF"[IBDINP("SORTBY")
DO @IBDINP("SORTBY")
if '$DATA(IBDINP("FORM"))
QUIT 0
+9 QUIT 1
+10 ;
SC ;Clinic selector
+1 NEW IBDI
+2 SET IBDOUT=0
FOR IBDI=1:1:30
SET IBDCL1=$$SC1("Select CLINIC: ")
if IBDOUT
QUIT
+3 QUIT
+4 ;
SC1(IBDICA) ;Select a clinic
SC2 KILL DIC
SET DIC("A")=IBDICA
SET DIC="^SC("
SET DIC(0)="AEMQZN"
SET DIC("S")="I $P(^(0),U,3)=""C"""
DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(X="")
SET IBDOUT=1
QUIT ""
+1 SET IBDINP("CLINIC",$PIECE(Y,U,2))=$PIECE(Y,U)
+2 QUIT $PIECE(Y,U,2)
+3 ;
RC ;Clinic range selector
+1 SET IBDCL1=$$SC1("Select beginning CLINIC: ")
if '$LENGTH(IBDCL1)
QUIT
RCE SET IBDCL2=$$SC1("Select ending CLINIC: ")
IF '$LENGTH(IBDCL2)
WRITE !,"Ending clinic must be specified!"
KILL IBDINP("CLINIC")
QUIT
+1 IF IBDCL1]IBDCL2
KILL IBDINP("CLINIC",IBDCL2)
WRITE !!,$CHAR(7),"Ending clinic must collate after beginning clinic!"
GOTO RCE
+2 SET IBDINP("CLINIC","RC",1)=IBDCL1
SET IBDINP("CLINIC","RC",2)=IBDCL2
+3 QUIT
+4 ;
SG ;Clinic GROUP selector
+1 NEW IBDI
+2 SET IBDOUT=0
FOR IBDI=1:1:30
SET IBDCL1=$$SG1("Select Clinic GROUP: ")
if IBDOUT
QUIT
+3 QUIT
+4 ;
SG1(IBDICA) ;Select a clinic GROUP
SG2 ;
+1 KILL DIC
SET DIC("A")=IBDICA
SET DIC="^IBD(357.99,"
SET DIC(0)="AEMQZ"
DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(X="")
SET IBDOUT=1
QUIT ""
+2 SET IBDINP("GROUP",$PIECE(Y,U,2))=$PIECE(Y,U)
+3 QUIT $PIECE(Y,U,2)
+4 ;
RG ;Clinic range selector
+1 SET IBDCL1=$$SG1("Select beginning Clinic GROUP: ")
if '$LENGTH(IBDCL1)
QUIT
RGE SET IBDCL2=$$SG1("Select ending Clinic GROUP: ")
IF '$LENGTH(IBDCL2)
WRITE !,"Ending clinic group must be specified!"
KILL IBDINP("GROUP")
QUIT
+1 IF IBDCL1]IBDCL2
KILL IBDINP("GROUP",IBDCL2)
WRITE !!,$CHAR(7),"Ending clinic group must collate after beginning clinic!"
GOTO RGE
+2 SET IBDINP("GROUP","RG",1)=IBDCL1
SET IBDINP("GROUP","RG",2)=IBDCL2
+3 QUIT
+4 ;
SF ;Encounter Form selector
+1 NEW IBDI
+2 SET IBDOUT=0
FOR IBDI=1:1:30
SET IBDCL1=$$SF1("Select Encounter Form: ")
if IBDOUT
QUIT
+3 QUIT
+4 ;
SF1(IBDICA) ;Select an Encounter Form
SF2 KILL DIC
SET DIC("A")=IBDICA
SET DIC="^IBE(357,"
SET DIC(0)="AEMQZ"
DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(X="")
SET IBDOUT=1
QUIT ""
+1 SET IBDINP("FORM",$PIECE(Y,U,2))=$PIECE(Y,U)
+2 QUIT $PIECE(Y,U,2)
+3 ;
RF ;Clinic range selector
+1 SET IBDCL1=$$SF1("Select beginning Encounter Form: ")
if '$LENGTH(IBDCL1)
QUIT
RFE SET IBDCL2=$$SF1("Select ending Encounter Form: ")
IF '$LENGTH(IBDCL2)
WRITE !,"Ending Encounter Form must be specified!"
KILL IBDINP("FORM")
QUIT
+1 IF IBDCL1]IBDCL2
KILL IBDINP("FORM",IBDCL2)
WRITE !!,$CHAR(7),"Ending Encounter Form must collate after Encounter Form!"
GOTO RFE
+2 SET IBDINP("FORM","RF",1)=IBDCL1
SET IBDINP("FORM","RF",2)=IBDCL2
+3 QUIT
+4 ;
HDR ; -- header code
+1 SET VALMHDR(1)=" ENCOUNTER FORM ICD9/ LAST EDITED ICD10 CLINIC"
+2 SET VALMHDR(2)=" ICD10 ICD9 ICD10 STATUS "
+3 QUIT
+4 ;
INIT ;
+1 DO FULL^VALM1
DO KILL^VALM10()
+2 KILL ^TMP("IBDFUTL4",$JOB),^TMP("IBDFUTL4X",$JOB)
+3 DO SORT
+4 IF '$DATA(^TMP("IBDFUTL4",$JOB))
SET ^TMP("IBDFUTL4",$JOB,1,0)=" "
SET ^TMP("IBDFUTL4",$JOB,2,0)="No records found"
+5 QUIT
+6 ;
HELP ;
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
CL ;
+1 DO FULL^VALM1
SET IBDRE=1
+2 DO PROMPTS
+3 QUIT
+4 ;
JP ;
+1 NEW IBDI,IBDX,IBDY,IBDARR,IBDSB,IBDQUIT,IBDL,IBDRES,IBDN
+2 DO FULL^VALM1
JMP ;
+1 SET DIC=$SELECT($EXTRACT(IBDINP("SORTBY"),2)="F":"^IBE(357,",$EXTRACT(IBDINP("SORTBY"),2)="G":"^IBD(357.99,",1:"^SC(")
+2 SET DIC(0)="AEMN"
SET DIC("A")="Select the "_$SELECT($EXTRACT(IBDINP("SORTBY"),2)="F":"Encounter Form",$EXTRACT(IBDINP("SORTBY"),2)="G":"Clinic Group",1:"Clinic")_" that you wish to move to: "
+3 if $EXTRACT(IBDINP("SORTBY"),2)="C"
SET DIC("S")="I $P(^SC(+Y,0),U,3)=""C"""
+4 DO ^DIC
KILL DIC
+5 IF X["^"
SET VALMBG=1
SET VALMBCK="R"
QUIT
+6 IF Y<0
GOTO JP
+7 SET IBDX=$SELECT($EXTRACT(IBDINP("SORTBY"),2)="F":$PIECE(^IBE(357,+Y,0),"^",1),$EXTRACT(IBDINP("SORTBY"),2)="G":$PIECE(^IBD(357.99,+Y,0),"^",1),1:$PIECE(^SC(+Y,0),"^",1))
+8 IF '$DATA(IBDX)
WRITE !!,"There is no data listed for this Clinic Group"
GOTO JMP
+9 IF $EXTRACT(IBDINP("SORTBY"),2)="C"
SET IBDSB="CLNA"
+10 IF $EXTRACT(IBDINP("SORTBY"),2)="F"
SET IBDSB="FMNA"
+11 IF $EXTRACT(IBDINP("SORTBY"),2)="G"
SET IBDSB="GPNA"
+12 SET IBDY=$ORDER(^TMP("IBDFUTL4X",$JOB,"X",IBDSB,IBDX),-1)
SET (IBDI,IBDQUIT,IBDL)=0
SET IBDRES=""
KILL IBDARR
+13 FOR
SET IBDY=$ORDER(^TMP("IBDFUTL4X",$JOB,"X",IBDSB,IBDY))
if IBDY=""!($EXTRACT(IBDY,1,$LENGTH(IBDX))'=IBDX)
QUIT
Begin DoDot:1
+14 SET IBDI=IBDI+1
SET IBDARR(IBDI)=IBDY
End DoDot:1
+15 IF IBDI=1
SET IBDRES=IBDARR(1)
GOTO JP5
+16 SET IBDN=""
SET IBDI=0
FOR
SET IBDN=$ORDER(IBDARR(IBDN))
if IBDN=""
QUIT
SET IBDI=IBDI+1
WRITE !,IBDN,". ",IBDARR(IBDN)
Begin DoDot:1
+17 IF '(IBDI#5)
SET IBDL=IBDI
DO JPDIS
if $DATA(DTOUT)!($DATA(DUOUT))!(Y=U)
SET IBDQUIT=1
if IBDQUIT
QUIT
Begin DoDot:2
+18 SET Y=+Y
IF Y>0
SET IBDRES=IBDARR(Y)
End DoDot:2
if IBDRES'=""
QUIT
End DoDot:1
if IBDQUIT!(IBDRES'="")
QUIT
+19 IF IBDQUIT
SET VALMBCK="R"
QUIT
+20 IF IBDRES=""
IF IBDI>IBDL
DO JPDIS
if $DATA(DTOUT)!($DATA(DUOUT))!(Y=U)
QUIT
SET Y=+Y
IF Y>0
SET IBDRES=IBDARR(Y)
+21 IF IBDRES=""
SET VALMBCK="R"
QUIT
JP5 ;
+1 SET IBDROW=$ORDER(^TMP("IBDFUTL4X",$JOB,"X",IBDSB,IBDRES,""))
+2 SET VALMBG=IBDROW
SET VALMBCK="R"
+3 ;
+4 QUIT
+5 ;
JPDIS ;
+1 WRITE !,"Press <RETURN> to see more, '^' to exit this list, OR"
+2 SET DIR(0)="NO^1:"_IBDI
SET DIR("A")="Choose 1-"_IBDI
DO ^DIR
+3 QUIT
+4 ;
IS ;UPDATE ICD10 STATUS FIELD
+1 NEW IBDI,IBDX,IBDY,IBDFM,IBDN,IBDQUIT,IBDPR,IBDROW,IBDSTA
+2 IF '$DATA(^TMP("IBDFUTL4X",$JOB,"D",0))
SET VALMBCK="R"
QUIT
+3 KILL DIR
SET DIR(0)="L^1:"_^TMP("IBDFUTL4X",$JOB,"D",0)
DO ^DIR
+4 IF $DATA(DTOUT)!($DATA(DUOUT))!(Y=U)
SET VALMBCK="R"
QUIT
+5 SET IBDY=Y
SET (IBDQUIT,IBDROW)=0
FOR IBDI=1:1:$LENGTH(Y,",")
SET IBDLI=$PIECE(IBDY,",",IBDI)
IF IBDLI?1.N
if IBDROW=0
SET IBDROW=IBDLI
Begin DoDot:1
+6 SET IBDFM=$GET(^TMP("IBDFUTL4X",$JOB,"X","FM",IBDLI))
if IBDFM'?1.N
QUIT
+7 SET IBDX=$GET(^IBE(357,IBDFM,0))
if IBDX=""
QUIT
WRITE !,"Encounter Form: ",$PIECE(IBDX,U,1)
+8 SET IBDSTA=""
SET IBDN=$ORDER(^IBE(357,IBDFM,3,"B",30,""))
IF IBDN?1.N
SET IBDX=^IBE(357,IBDFM,3,IBDN,0)
SET IBDSTA=$PIECE(IBDX,U,2)
+9 KILL DIR
Begin DoDot:2
+10 IF IBDSTA=""
SET IBDPR="Update Status to [C]omplete or [R]eview"
SET DIR(0)="S^C:Complete;R:Review"
SET DIR("B")="Complete"
+11 IF IBDSTA="C"
SET IBDPR="Update Status to [I]ncomplete or [R]eview"
SET DIR(0)="S^I:Incomplete;R:Review"
SET DIR("B")="Incomplete"
+12 IF IBDSTA="R"
SET IBDPR="Update Status to [C]omplete or [I]ncomplete"
SET DIR(0)="S^C:Complete;I:Incomplete"
SET DIR("B")="Complete"
End DoDot:2
+13 SET DIR("A")=IBDPR
DO ^DIR
KILL DIR
IF ($DATA(DTOUT)!$DATA(DUOUT))
SET IBDQUIT=1
QUIT
+14 SET IBDPR="Are you changing the Status from "_$SELECT(IBDSTA="":"Incomplete",IBDSTA="C":"Complete",1:"Review")_" to "_$SELECT(Y="I":"Incomplete",Y="C":"Complete",1:"Review")
+15 SET IBDX=$$YESNO^IBDUTIL1(IBDPR,"Y",0,300)
+16 IF IBDX=1
SET IBDX=$$YESNO^IBDUTIL1("Are you sure you want to change the status","NO",0,300)
+17 IF IBDX=1
if Y="I"
SET Y="@"
SET IBDX=$$CSUPD357^IBDUTICD(IBDFM,30,Y,$$NOW^XLFDT(),DUZ)
End DoDot:1
if IBDQUIT
QUIT
+18 DO SORT
+19 SET VALMBCK="R"
+20 QUIT
+21 ;
EXP ;
+1 QUIT
