TIUPXAPI.m

TIUPXAPI ; SLC/JER - Interface w/PCE/Visit Tracking ;23-Jan-2014 17:17;DU

 ;;1.0;TEXT INTEGRATION UTILITIES;**15,24,29,82,107,126,161,267,1013**;Jun 20, 1997;Build 33

CREDIT(DFN,TIU,VSIT) ; Get Dx, CPT, (& SC) for the CMD's mandate

 N TIUCPT,TIUAICD,TIUICDAR,TIUCPTAR,TIUSC,DTOUT,TIUOK,TIUPRLST

 ; For Historical Visits, just QUEUE the PXAPI call and quit

 I $P(TIU("VSTR"),";",3)="E" D QUE^TIUPXAP1 Q

 ; If no Location, and not Historical Visit, then quit

 Q:+$G(TIU("VSTR"))'>0

REENTER I $G(VALMAR)="^TMP(""TIUR"",$J)",$D(TIU("PNM")) D

 . W !!,"For ",$G(TIU("PNM"))," ",$G(TIU("PID"))," Visit on "

 . W $P($G(TIU("EDT")),U,2),"..."

 D PROVLIST(.TIUPRLST)

 N TIUVDT S TIUVDT=$P($G(TIU("VSTR")),";",2)

 ; *161 Pass encounter date to GETICD as 3rd and 4th variable, then to IBDF18A

 D GETICD(TIU("LOC"),.TIUICDAR,TIUVDT)

ICDCALL D ICD(.TIUAICD,.TIUICDAR,TIUVDT) G:+$G(DTOUT) INSUFF ; **15**

 I '$D(TIUAICD),'$D(DTOUT) W !!,$C(7),"You MUST enter one or more Diagnoses." H 3 G ICDCALL

 K TIUICDAR ; **15**

 ; Pass encounter date to TIUPXAPC to pass to IBDF18A **161**

 D GETCPT^TIUPXAPC(TIU("LOC"),.TIUCPTAR,TIUVDT)

 ; Pass encounter date to TIUPXAPC,ICPTCOD,TIUPXAPM for CSV **161**

CPTCALL D CPT^TIUPXAPC(.TIUCPT,.TIUCPTAR,TIUVDT) G:+$G(DTOUT) INSUFF

 I '$D(TIUCPT),'$D(DTOUT) W !!,$C(7),"You MUST enter one or more Procedures." H 3 G CPTCALL

 K TIUCPTAR ; **15**

 D SCASK^TIUPXAPS(.TIUSC,+DFN,.TIU)

INSUFF I $D(DTOUT)!(+$O(TIUAICD(0))'>0)&(+$O(TIUCPT(0))'>0)&(+$O(TIUSC(0))'>0) D  G POST

 . W !,$C(7),"Insufficient information for Workload Credit."

 . W !,"Missing information will have to be captured by another method."

 S TIUOK=$$CONFIRM(.TIUAICD,.TIUCPT,.TIUSC)

 I '+TIUOK D  G REENTER

 . W !!,"Changes Discarded. Please Enter Corrected Workload Data..." H 3

 . K TIUAICD,TIUCPT,TIUSC,TIUICDAR,TIUCPTAR

 K TIUCPTAR,TIUICDAR

 W !!,"Posting Workload Credit..."

POST N ICD,CPT,SC

 M ICD=TIUAICD,CPT=TIUCPT,SC=TIUSC

 D QUE^TIUPXAP1 ; Queue TIU/PXAPI RESOURCE

 W:'+$G(DTOUT) "Done."

 Q

CONFIRM(TIUAICD,TIUCPT,TIUSC) ; Show user and confirm

 N TIUI,TIUY S TIUY=0

 W !!,"You have indicated the following data apply to this visit:",!

 W !,"DIAGNOSES:"

 S TIUI=0

 F  S TIUI=$O(TIUAICD(TIUI)) Q:+TIUI'>0  D

 . W !?3,$P(TIUAICD(TIUI),U,2),?12,$E($P(TIUAICD(TIUI),U,3),1,67)

 . W:+$G(TIUAICD(TIUI,"PRIMARY")) "  <<< PRIMARY"

 W !!,"PROCEDURES:"

 S TIUI=0

 F  S TIUI=$O(TIUCPT(TIUI)) Q:+TIUI'>0  D

 . W !?3,$P(TIUCPT(TIUI),U,4),?12,$E($P(TIUCPT(TIUI),U,2),1,67)

 . ;Display CPT Modifiers

 . D DISMOD^TIUPXAPM(.TIUCPT,TIUI)

 I $D(TIUSC)>9 D

 . W !!,"SERVICE CONNECTION:"

 . W !?3,"Service Connected? ",$S(+$G(TIUSC("SC")):"YES",1:"NO")

 . I $D(TIUSC("AO")),+$G(TIUSC("SC"))'>0 W !?3,"Agent Orange? ",$S($G(TIUSC("AO"))]"":$P($G(TIUSC("AO")),U,2),1:"NOT ANSWERED")

 . I $D(TIUSC("IR")),+$G(TIUSC("SC"))'>0 W !?3,"Ionizing Radiation? ",$S($G(TIUSC("IR"))]"":$P($G(TIUSC("IR")),U,2),1:"NOT ANSWERED")

 . I $D(TIUSC("EC")),+$G(TIUSC("SC"))'>0 W !?3,"Environmental Contaminants? ",$S($G(TIUSC("EC"))]"":$P($G(TIUSC("EC")),U,2),1:"NOT ANSWERED")

 . I $D(TIUSC("MST")) W !?3,"MST? ",$S($G(TIUSC("MST"))]"":$P($G(TIUSC("MST")),U,2),1:"NOT ANSWERED")

 . I $D(TIUSC("HNC")) W !?3,"Head and/or Neck Cancer? ",$S($G(TIUSC("HNC"))]"":$P($G(TIUSC("HNC")),U,2),1:"NOT ANSWERED")

 W ! S TIUY=+$$READ^TIUU("Y","   ...OK","YES")

 Q +$G(TIUY)

 ; Pass encounter date to GETICD to pass to IBDF18A **161**

GETICD(TIULOC,TIUICDAR,TIUVDT) ; Get ICD-9 codes for clinic

 N TIUI,TIUROW,TIUCOL,ARRY2,TIUITM,TIUPAGE,TIUCAT S TIUCAT=""

 Q  ;IHS does not use VA Integrated billing IHS/MSC/MGH Patch 1013

 ; Pass encounter date as the 5th parameter to IBDF18A **161**

 ;IHS/MSC/MGH IBDF is not used in IHS  Patch 1013

 ;D GETLST^IBDF18A(+TIULOC,"DG SELECT ICD-9 DIAGNOSIS CODES","ARRY2",,,,TIUVDT) ; ICR 1296

 S (TIUI,TIUROW,TIUITM)=0,(TIUCOL,TIUPAGE)=1

 F  S TIUI=$O(ARRY2(TIUI)) Q:+TIUI'>0  D

 . I $P(ARRY2(TIUI),U)]"" D  I 1

 . . S TIUROW=+$G(TIUROW)+1,TIUITM=+$G(TIUITM)+1

 . . S TIUICDAR(TIUROW,TIUCOL)=TIUITM_U_$G(ARRY2(TIUI))_U_TIUCAT

 . . S TIUICDAR("INDEX",TIUITM)=$G(ARRY2(TIUI))_U_TIUCAT K ARRY2(TIUI)

 . E  D

 . . S TIUROW=+$G(TIUROW)+1,TIUCAT=$$UP^XLFSTR($P($G(ARRY2(TIUI)),U,2))

 . . S TIUICDAR(TIUROW,TIUCOL)=U_U_TIUCAT

 . . K ARRY2(TIUI)

 . I (TIUROW#20'>0),(TIUCOL=3) S TIUPAGE=TIUPAGE+1

 . I TIUROW#20'>0 S TIUCOL=$S(TIUCOL=3:1,1:TIUCOL+1),TIUROW=20*(TIUPAGE-1)

 I +$G(ARRY2(0))>0 D

 . S TIUROW=+$G(TIUROW)+1,TIUITM=TIUITM+1

 . S TIUICDAR(TIUROW,TIUCOL)=TIUITM_"^OTHER ICD^OTHER Diagnosis"

 . S TIUICDAR("INDEX",TIUITM)="OTHER ICD^OTHER Diagnosis"

 . S TIUICDAR(0)=+$G(ARRY2(0))_U_+$G(TIUROW)_U_+$G(TIUPAGE)

 . I (TIUROW#20'>0),(TIUCOL=3) S TIUPAGE=TIUPAGE+1

 . I TIUROW#20'>0 S TIUCOL=$S(TIUCOL=3:1,1:TIUCOL+1),TIUROW=20*(TIUPAGE-1)

 Q

 ; Pass encounter date as TIUVDT for CSV **161**

ICD(TIUAICD,TIUICDAR,TIUVDT) ; Select Dx's

 N TIUI,J,L,Y,TIUICD,TIUICNT,TIUPGS,TIUPG,TIUITM,TIULITM,TIUPNM

 S TIUPNM=$S($L($G(TIU("PNM"))):$G(TIU("PNM")),+$G(DFN):$$PTNAME^TIULC1(DFN),1:"the Patient")

 W !!,"Please Indicate the Diagnoses for which "_TIUPNM_" was Seen:"

 W:+$O(TIUICDAR(0)) !

 S TIUICNT=+$G(TIUICDAR(0)),TIUPGS=$P($G(TIUICDAR(0)),U,3)

 S (TIUI,J,L,Y)=0 I +TIUICNT S TIUPG=1

 F  S TIUI=$O(TIUICDAR(TIUI)) Q:+TIUI'>0  D  Q:+$G(DTOUT)

 . S J=0 W ! F  S J=$O(TIUICDAR(TIUI,J)) Q:+J'>0  D

 . . W ?((J-1)*25) W:+$P(TIUICDAR(TIUI,J),U) $J($P(TIUICDAR(TIUI,J),U),2)_" " W $E($P(TIUICDAR(TIUI,J),U,3),1,20)

 . . S TIUITM=$S(+$G(TIUICDAR(TIUI,J)):+$G(TIUICDAR(TIUI,J)),1:$G(TIUITM))

 . . S:TIUITM>+$G(TIULITM) TIULITM=TIUITM

 . I TIUI#20=0 S Y=$S(+Y:Y,1:"")_$P($$PICK^TIUPXAP2(1,+$G(TIULITM),"Select Diagnoses"_$S(+$G(TIUPG)<TIUPGS:" (<RETURN> to see next page of choices)",1:"")),U),TIUPG=+$G(TIUPG)+1 W !

 . S L=TIUI S:TIUITM>+$G(TIULITM) TIULITM=TIUITM

 I +$G(DTOUT) Q

 I L#20 S Y=$S(+Y:Y,1:"")_$P($$PICK^TIUPXAP2(1,TIULITM,"Select Diagnoses"),U)

 I +Y,$P(TIUICDAR("INDEX",+Y),U)'="OTHER ICD" D  I 1

 . N TIUI,ITEM F TIUI=1:1:($L(Y,",")-1) D  Q:+$G(DTOUT)

 . . S ITEM=$P(Y,",",TIUI)

 . . I $P(TIUICDAR("INDEX",+ITEM),U)'="OTHER ICD" D

 . . . ;S TIUICD=+$O(^ICD9("AB",$P(TIUICDAR("INDEX",+ITEM),U)_" ",0))

 . . . S TIUICD=+$$CODEN^ICDCODE($P(TIUICDAR("INDEX",+ITEM),U),80)

 . . . S TIUAICD(TIUI)=TIUICD_U_$G(TIUICDAR("INDEX",+ITEM))

 . . ; Pass encounter date to ICDOUT to pass to LEXSET for CSV **161**

 . . E  D ICDOUT(.TIUAICD,.TIUI,TIUVDT)

 Q:+$G(DTOUT)

 ; Pass encounter date to ICDOUT to pass to LEXSET for CSV **161**

 E  D ICDOUT(.TIUAICD,,TIUVDT)

 I +$O(TIUAICD(1)) D ASKPRMRY(.TIUAICD) I 1

 Q:+$G(DTOUT)

 E  I $D(TIUAICD(1)) S TIUAICD(1,"PRIMARY")=1

 Q

ASKPRMRY(TIUAICD) ; Which Dx is Primary

 N TIUI,L,Y

PRMAGN W !!,"Please indicate which of the Diagnoses is the Primary Diagnosis:",!

 S (TIUI,L,Y)=0 F  S TIUI=$O(TIUAICD(TIUI)) Q:+TIUI'>0!+Y  D

 . W:$P(TIUAICD(TIUI),U)]"" !,TIUI,?7,$P(TIUAICD(TIUI),U,3)

 . I TIUI#20=0 S Y=$P($$PICK^TIUPXAP2(1,TIUI,"Select Diagnosis","NO"),U)

 . S L=TIUI

 I L#20,'+Y S Y=$P($$PICK^TIUPXAP2(1,L,"Select Diagnosis","NO"),U)

 I +Y'>0 W !!?3,$C(7),"You must specify a Primary Diagnosis." G PRMAGN

 I +Y,$D(TIUAICD(+Y)) S TIUAICD(+Y,"PRIMARY")=1

 Q

ICDOUT(TIUAICD,TIUI,TIUVDT) ; Go off-list for Dx

 N DIC,X,Y,TIUICD,TIUOUT

 F  D  Q:+$G(TIUOUT)

 . I $L($T(CONFIG^LEXSET)) D  I 1

 . . ; Pass encounter date to LEXSET for CSV **161**

 . . D CONFIG^LEXSET("ICD","ICD",TIUVDT) ; ICR 1609

 . E  D  Q

 . . W !,$C(7),"You must install LEXICON UTILITY v2.0 for this function to work...Contact IRM.",!

 . . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause

 . . S TIUOUT=1

 . S DIC(0)="AEMQ"

 . S DIC("A")="Select "_$S(+$G(TIUICDAR(0))'>0:"Diagnosis: ",1:"Another Diagnosis"_$S($D(TIUICDAR):" (NOT from Above List)",1:"")_": ")

 . N X K DIC("B")

 . D ^DIC

 . I +$D(DTOUT)!+$D(DUOUT)!(X="") S TIUOUT=1 Q

 . I $G(Y(1))]"" D  Q

 . . ;S TIUICD=+$O(^ICD9("AB",$P(Y(1),U)_" ",0))

 . . S TIUICD=+$$CODEN^ICDCODE($P(Y(1),U),80) ;ICR 3990

 . . ;S:TIUICD'>0 TIUICD=+$O(^ICD9("AB",$P(Y(1),U)_"0 ",0))

 . . S:TIUICD'>0 TIUICD=+$$CODEN^ICDCODE($P(Y(1),U)_"0",80)

 . . I +TIUICD'>0 W !,$C(7),"ICD CODE NOT FOUND FOR EXPRESSION." Q

 . . S:$S(+$G(TIUI)'>0:1,$D(TIUAICD(+$G(TIUI))):1,1:0) TIUI=$G(TIUI)+1

 . . S TIUAICD(TIUI)=TIUICD_U_Y(1)_U_$P(Y,U,2)

 . W $C(7),!!,"Nothing found for ",X,"..."

 . F  D  Q:(+Y>0)!+$G(TIUOUT)

 . . N X

 . . I $L($T(CONFIG^LEXSET)) D  I 1

 . . . ; Pass encounter date to LEXSET for CSV **161**

 . . . D CONFIG^LEXSET("ICD","ICD",TIUVDT)

 . . E  D  Q

 . . . W !,$C(7),"You must install LEXICON UTILITY v2.0 for this function to work...Contact IRM.",!

 . . . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause

 . . . S TIUOUT=1

 . . S DIC("A")="Please try another expression, or RETURN to continue: "

 . . D ^DIC

 . . I +$D(DTOUT)!+$D(DUOUT)!(X="") S TIUOUT=1 Q

 . . I +$G(Y(1))>0 D  Q

 . . . ;S TIUICD=+$O(^ICD9("AB",$P(Y(1),U)_" ",0))

 . . . S TIUICD=+$$CODEN^ICDCODE($P(Y(1),U),80)

 . . . S:$S(+$G(TIUI)'>0:1,$D(TIUAICD(+$G(TIUI))):1,1:0) TIUI=$G(TIUI)+1

 . . . S TIUAICD(TIUI)=TIUICD_U_Y(1)_U_$P(Y,U,2)

 . . W $C(7),!!,"Nothing found for ",X,"..."

 Q

PROVLIST(PROVLIST) ; Identify primary provider

 N PRIMARY,DFLT,DUOUT S DFLT=""

 W !

 I +$P($G(TIUPRM0),U,8)=0 Q

 I +$P($G(TIUPRM0),U,8)=1 S DFLT=$$DFLTDOC(+TIU("VLOC"))

 I +DFLT=DUZ S PROVLIST(1,"NAME")=DUZ,PROVLIST(1,"PRIMARY")=1 Q

 I +DFLT S DFLT=$P(DFLT,U,2)

 S:DFLT']"" DFLT=$S($$PROVIDER^TIUPXAP1(DUZ,DT):$$PERSNAME^TIULC1(DUZ),1:"")

ASKPR S PRIMARY=+$$ASKDOC(DFLT)

 I +PRIMARY'>0 Q

 I '+$$PROVIDER^TIUPXAP1(PRIMARY,DT) D  G ASKPR

 . W !,$C(7),"  Selected user is not a known PROVIDER. Please choose another..."

 S PROVLIST(1,"NAME")=DUZ

 I PRIMARY=DUZ S PROVLIST(1,"PRIMARY")=1

 E  S PROVLIST(2,"NAME")=PRIMARY,PROVLIST(2,"PRIMARY")=1,PROVLIST(1,"PRIMARY")=0

 Q

ASKDOC(DFLT) ; Call ^DIC to look-up provider

 N DIC,X,Y

 S DIC=200,DIC(0)="AEMQ",DIC("A")="Select PRIMARY PROVIDER: "

 I $G(DFLT)]"" S DIC("B")=$G(DFLT)

 D ^DIC

 Q +Y

DFLTDOC(HLOC) ; Get the default Provider

 N PXBPMT,TIUPNM,Y S Y=""

 D PRV^PXBUTL2(HLOC) ; ICR 3152

 I $D(PXBPMT("DEF")) S TIUPNM=$O(PXBPMT("DEF","")),Y=$O(PXBPMT("DEF",TIUPNM,0))_U_TIUPNM

 Q Y

TIUPXAPI  ; SLC/JER - Interface w/PCE/Visit Tracking ;23-Jan-2014 17:17;DU

 +1       ;;1.0;TEXT INTEGRATION UTILITIES;**15,24,29,82,107,126,161,267,1013**;Jun 20, 1997;Build 33

CREDIT(DFN,TIU,VSIT) ; Get Dx, CPT, (& SC) for the CMD's mandate

 +1        NEW TIUCPT,TIUAICD,TIUICDAR,TIUCPTAR,TIUSC,DTOUT,TIUOK,TIUPRLST

 +2       ; For Historical Visits, just QUEUE the PXAPI call and quit

 +3        IF $PIECE(TIU("VSTR"),";",3)="E"

               DO QUE^TIUPXAP1

               QUIT 

 +4       ; If no Location, and not Historical Visit, then quit

 +5        IF +$GET(TIU("VSTR"))'>0

               QUIT 

REENTER    IF $GET(VALMAR)="^TMP(""TIUR"",$J)"

               IF $DATA(TIU("PNM"))

                   Begin DoDot:1

 +1                    WRITE !!,"For ",$GET(TIU("PNM"))," ",$GET(TIU("PID"))," Visit on "

 +2                    WRITE $PIECE($GET(TIU("EDT")),U,2),"..."

                   End DoDot:1

 +3        DO PROVLIST(.TIUPRLST)

 +4        NEW TIUVDT

           SET TIUVDT=$PIECE($GET(TIU("VSTR")),";",2)

 +5       ; *161 Pass encounter date to GETICD as 3rd and 4th variable, then to IBDF18A

 +6        DO GETICD(TIU("LOC"),.TIUICDAR,TIUVDT)

ICDCALL   ; **15**

           DO ICD(.TIUAICD,.TIUICDAR,TIUVDT)

           IF +$GET(DTOUT)

               GOTO INSUFF

 +1        IF '$DATA(TIUAICD)

               IF '$DATA(DTOUT)

                   WRITE !!,$CHAR(7),"You MUST enter one or more Diagnoses."

                   HANG 3

                   GOTO ICDCALL

 +2       ; **15**

           KILL TIUICDAR

 +3       ; Pass encounter date to TIUPXAPC to pass to IBDF18A **161**

 +4        DO GETCPT^TIUPXAPC(TIU("LOC"),.TIUCPTAR,TIUVDT)

 +5       ; Pass encounter date to TIUPXAPC,ICPTCOD,TIUPXAPM for CSV **161**

CPTCALL    DO CPT^TIUPXAPC(.TIUCPT,.TIUCPTAR,TIUVDT)

           IF +$GET(DTOUT)

               GOTO INSUFF

 +1        IF '$DATA(TIUCPT)

               IF '$DATA(DTOUT)

                   WRITE !!,$CHAR(7),"You MUST enter one or more Procedures."

                   HANG 3

                   GOTO CPTCALL

 +2       ; **15**

           KILL TIUCPTAR

 +3        DO SCASK^TIUPXAPS(.TIUSC,+DFN,.TIU)

INSUFF     IF $DATA(DTOUT)!(+$ORDER(TIUAICD(0))'>0)&(+$ORDER(TIUCPT(0))'>0)&(+$ORDER(TIUSC(0))'>0)

               Begin DoDot:1

 +1                WRITE !,$CHAR(7),"Insufficient information for Workload Credit."

 +2                WRITE !,"Missing information will have to be captured by another method."

               End DoDot:1

               GOTO POST

 +3        SET TIUOK=$$CONFIRM(.TIUAICD,.TIUCPT,.TIUSC)

 +4        IF '+TIUOK

               Begin DoDot:1

 +5                WRITE !!,"Changes Discarded. Please Enter Corrected Workload Data..."

                   HANG 3

 +6                KILL TIUAICD,TIUCPT,TIUSC,TIUICDAR,TIUCPTAR

               End DoDot:1

               GOTO REENTER

 +7        KILL TIUCPTAR,TIUICDAR

 +8        WRITE !!,"Posting Workload Credit..."

POST       NEW ICD,CPT,SC

 +1        MERGE ICD=TIUAICD,CPT=TIUCPT,SC=TIUSC

 +2       ; Queue TIU/PXAPI RESOURCE

           DO QUE^TIUPXAP1

 +3        IF '+$GET(DTOUT)

               WRITE "Done."

 +4        QUIT 

CONFIRM(TIUAICD,TIUCPT,TIUSC) ; Show user and confirm

 +1        NEW TIUI,TIUY

           SET TIUY=0

 +2        WRITE !!,"You have indicated the following data apply to this visit:",!

 +3        WRITE !,"DIAGNOSES:"

 +4        SET TIUI=0

 +5        FOR 

               SET TIUI=$ORDER(TIUAICD(TIUI))

               IF +TIUI'>0

                   QUIT 

               Begin DoDot:1

 +6                WRITE !?3,$PIECE(TIUAICD(TIUI),U,2),?12,$EXTRACT($PIECE(TIUAICD(TIUI),U,3),1,67)

 +7                IF +$GET(TIUAICD(TIUI,"PRIMARY"))

                       WRITE "  <<< PRIMARY"

               End DoDot:1

 +8        WRITE !!,"PROCEDURES:"

 +9        SET TIUI=0

 +10       FOR 

               SET TIUI=$ORDER(TIUCPT(TIUI))

               IF +TIUI'>0

                   QUIT 

               Begin DoDot:1

 +11               WRITE !?3,$PIECE(TIUCPT(TIUI),U,4),?12,$EXTRACT($PIECE(TIUCPT(TIUI),U,2),1,67)

 +12      ;Display CPT Modifiers

 +13               DO DISMOD^TIUPXAPM(.TIUCPT,TIUI)

               End DoDot:1

 +14       IF $DATA(TIUSC)>9

               Begin DoDot:1

 +15               WRITE !!,"SERVICE CONNECTION:"

 +16               WRITE !?3,"Service Connected? ",$SELECT(+$GET(TIUSC("SC")):"YES",1:"NO")

 +17               IF $DATA(TIUSC("AO"))

                       IF +$GET(TIUSC("SC"))'>0

                           WRITE !?3,"Agent Orange? ",$SELECT($GET(TIUSC("AO"))]"":$PIECE($GET(TIUSC("AO")),U,2),1:"NOT ANSWERED")

 +18               IF $DATA(TIUSC("IR"))

                       IF +$GET(TIUSC("SC"))'>0

                           WRITE !?3,"Ionizing Radiation? ",$SELECT($GET(TIUSC("IR"))]"":$PIECE($GET(TIUSC("IR")),U,2),1:"NOT ANSWERED")

 +19               IF $DATA(TIUSC("EC"))

                       IF +$GET(TIUSC("SC"))'>0

                           WRITE !?3,"Environmental Contaminants? ",$SELECT($GET(TIUSC("EC"))]"":$PIECE($GET(TIUSC("EC")),U,2),1:"NOT ANSWERED")

 +20               IF $DATA(TIUSC("MST"))

                       WRITE !?3,"MST? ",$SELECT($GET(TIUSC("MST"))]"":$PIECE($GET(TIUSC("MST")),U,2),1:"NOT ANSWERED")

 +21               IF $DATA(TIUSC("HNC"))

                       WRITE !?3,"Head and/or Neck Cancer? ",$SELECT($GET(TIUSC("HNC"))]"":$PIECE($GET(TIUSC("HNC")),U,2),1:"NOT ANSWERED")

               End DoDot:1

 +22       WRITE !

           SET TIUY=+$$READ^TIUU("Y","   ...OK","YES")

 +23       QUIT +$GET(TIUY)

 +24      ; Pass encounter date to GETICD to pass to IBDF18A **161**

GETICD(TIULOC,TIUICDAR,TIUVDT) ; Get ICD-9 codes for clinic

 +1        NEW TIUI,TIUROW,TIUCOL,ARRY2,TIUITM,TIUPAGE,TIUCAT

           SET TIUCAT=""

 +2       ;IHS does not use VA Integrated billing IHS/MSC/MGH Patch 1013

           QUIT 

 +3       ; Pass encounter date as the 5th parameter to IBDF18A **161**

 +4       ;IHS/MSC/MGH IBDF is not used in IHS  Patch 1013

 +5       ;D GETLST^IBDF18A(+TIULOC,"DG SELECT ICD-9 DIAGNOSIS CODES","ARRY2",,,,TIUVDT) ; ICR 1296

 +6        SET (TIUI,TIUROW,TIUITM)=0

           SET (TIUCOL,TIUPAGE)=1

 +7        FOR 

               SET TIUI=$ORDER(ARRY2(TIUI))

               IF +TIUI'>0

                   QUIT 

               Begin DoDot:1

 +8                IF $PIECE(ARRY2(TIUI),U)]""

                       Begin DoDot:2

 +9                        SET TIUROW=+$GET(TIUROW)+1

                           SET TIUITM=+$GET(TIUITM)+1

 +10                       SET TIUICDAR(TIUROW,TIUCOL)=TIUITM_U_$GET(ARRY2(TIUI))_U_TIUCAT

 +11                       SET TIUICDAR("INDEX",TIUITM)=$GET(ARRY2(TIUI))_U_TIUCAT

                           KILL ARRY2(TIUI)

                       End DoDot:2

                       IF 1

 +12              IF '$TEST

                       Begin DoDot:2

 +13                       SET TIUROW=+$GET(TIUROW)+1

                           SET TIUCAT=$$UP^XLFSTR($PIECE($GET(ARRY2(TIUI)),U,2))

 +14                       SET TIUICDAR(TIUROW,TIUCOL)=U_U_TIUCAT

 +15                       KILL ARRY2(TIUI)

                       End DoDot:2

 +16               IF (TIUROW#20'>0)

                       IF (TIUCOL=3)

                           SET TIUPAGE=TIUPAGE+1

 +17               IF TIUROW#20'>0

                       SET TIUCOL=$SELECT(TIUCOL=3:1,1:TIUCOL+1)

                       SET TIUROW=20*(TIUPAGE-1)

               End DoDot:1

 +18       IF +$GET(ARRY2(0))>0

               Begin DoDot:1

 +19               SET TIUROW=+$GET(TIUROW)+1

                   SET TIUITM=TIUITM+1

 +20               SET TIUICDAR(TIUROW,TIUCOL)=TIUITM_"^OTHER ICD^OTHER Diagnosis"

 +21               SET TIUICDAR("INDEX",TIUITM)="OTHER ICD^OTHER Diagnosis"

 +22               SET TIUICDAR(0)=+$GET(ARRY2(0))_U_+$GET(TIUROW)_U_+$GET(TIUPAGE)

 +23               IF (TIUROW#20'>0)

                       IF (TIUCOL=3)

                           SET TIUPAGE=TIUPAGE+1

 +24               IF TIUROW#20'>0

                       SET TIUCOL=$SELECT(TIUCOL=3:1,1:TIUCOL+1)

                       SET TIUROW=20*(TIUPAGE-1)

               End DoDot:1

 +25       QUIT 

 +26      ; Pass encounter date as TIUVDT for CSV **161**

ICD(TIUAICD,TIUICDAR,TIUVDT) ; Select Dx's

 +1        NEW TIUI,J,L,Y,TIUICD,TIUICNT,TIUPGS,TIUPG,TIUITM,TIULITM,TIUPNM

 +2        SET TIUPNM=$SELECT($LENGTH($GET(TIU("PNM"))):$GET(TIU("PNM")),+$GET(DFN):$$PTNAME^TIULC1(DFN),1:"the Patient")

 +3        WRITE !!,"Please Indicate the Diagnoses for which "_TIUPNM_" was Seen:"

 +4        IF +$ORDER(TIUICDAR(0))

               WRITE !

 +5        SET TIUICNT=+$GET(TIUICDAR(0))

           SET TIUPGS=$PIECE($GET(TIUICDAR(0)),U,3)

 +6        SET (TIUI,J,L,Y)=0

           IF +TIUICNT

               SET TIUPG=1

 +7        FOR 

               SET TIUI=$ORDER(TIUICDAR(TIUI))

               IF +TIUI'>0

                   QUIT 

               Begin DoDot:1

 +8                SET J=0

                   WRITE !

                   FOR 

                       SET J=$ORDER(TIUICDAR(TIUI,J))

                       IF +J'>0

                           QUIT 

                       Begin DoDot:2

 +9                        WRITE ?((J-1)*25)

                           IF +$PIECE(TIUICDAR(TIUI,J),U)

                               WRITE $JUSTIFY($PIECE(TIUICDAR(TIUI,J),U),2)_" "

                           WRITE $EXTRACT($PIECE(TIUICDAR(TIUI,J),U,3),1,20)

 +10                       SET TIUITM=$SELECT(+$GET(TIUICDAR(TIUI,J)):+$GET(TIUICDAR(TIUI,J)),1:$GET(TIUITM))

 +11                       IF TIUITM>+$GET(TIULITM)

                               SET TIULITM=TIUITM

                       End DoDot:2

 +12               IF TIUI#20=0

                       SET Y=$SELECT(+Y:Y,1:"")_$PIECE($$PICK^TIUPXAP2(1,+$GET(TIULITM),"Select Diagnoses"_$SELECT(+$GET(TIUPG)<TIUPGS:" (<RETURN> to see next page of choices)",1:"")),U)

                       SET TIUPG=+$GET(TIUPG)+1

                       WRITE !

 +13               SET L=TIUI

                   IF TIUITM>+$GET(TIULITM)

                       SET TIULITM=TIUITM

               End DoDot:1

               IF +$GET(DTOUT)

                   QUIT 

 +14       IF +$GET(DTOUT)

               QUIT 

 +15       IF L#20

               SET Y=$SELECT(+Y:Y,1:"")_$PIECE($$PICK^TIUPXAP2(1,TIULITM,"Select Diagnoses"),U)

 +16       IF +Y

               IF $PIECE(TIUICDAR("INDEX",+Y),U)'="OTHER ICD"

                   Begin DoDot:1

 +17                   NEW TIUI,ITEM

                       FOR TIUI=1:1:($LENGTH(Y,",")-1)

                           Begin DoDot:2

 +18                           SET ITEM=$PIECE(Y,",",TIUI)

 +19                           IF $PIECE(TIUICDAR("INDEX",+ITEM),U)'="OTHER ICD"

                                   Begin DoDot:3

 +20      ;S TIUICD=+$O(^ICD9("AB",$P(TIUICDAR("INDEX",+ITEM),U)_" ",0))

 +21                                   SET TIUICD=+$$CODEN^ICDCODE($PIECE(TIUICDAR("INDEX",+ITEM),U),80)

 +22                                   SET TIUAICD(TIUI)=TIUICD_U_$GET(TIUICDAR("INDEX",+ITEM))

                                   End DoDot:3

 +23      ; Pass encounter date to ICDOUT to pass to LEXSET for CSV **161**

 +24                          IF '$TEST

                                   DO ICDOUT(.TIUAICD,.TIUI,TIUVDT)

                           End DoDot:2

                           IF +$GET(DTOUT)

                               QUIT 

                   End DoDot:1

                   IF 1

 +25       IF +$GET(DTOUT)

               QUIT 

 +26      ; Pass encounter date to ICDOUT to pass to LEXSET for CSV **161**

 +27      IF '$TEST

               DO ICDOUT(.TIUAICD,,TIUVDT)

 +28       IF +$ORDER(TIUAICD(1))

               DO ASKPRMRY(.TIUAICD)

               IF 1

 +29       IF +$GET(DTOUT)

               QUIT 

 +30      IF '$TEST

               IF $DATA(TIUAICD(1))

                   SET TIUAICD(1,"PRIMARY")=1

 +31       QUIT 

ASKPRMRY(TIUAICD) ; Which Dx is Primary

 +1        NEW TIUI,L,Y

PRMAGN     WRITE !!,"Please indicate which of the Diagnoses is the Primary Diagnosis:",!

 +1        SET (TIUI,L,Y)=0

           FOR 

               SET TIUI=$ORDER(TIUAICD(TIUI))

               IF +TIUI'>0!+Y

                   QUIT 

               Begin DoDot:1

 +2                IF $PIECE(TIUAICD(TIUI),U)]""

                       WRITE !,TIUI,?7,$PIECE(TIUAICD(TIUI),U,3)

 +3                IF TIUI#20=0

                       SET Y=$PIECE($$PICK^TIUPXAP2(1,TIUI,"Select Diagnosis","NO"),U)

 +4                SET L=TIUI

               End DoDot:1

 +5        IF L#20

               IF '+Y

                   SET Y=$PIECE($$PICK^TIUPXAP2(1,L,"Select Diagnosis","NO"),U)

 +6        IF +Y'>0

               WRITE !!?3,$CHAR(7),"You must specify a Primary Diagnosis."

               GOTO PRMAGN

 +7        IF +Y

               IF $DATA(TIUAICD(+Y))

                   SET TIUAICD(+Y,"PRIMARY")=1

 +8        QUIT 

ICDOUT(TIUAICD,TIUI,TIUVDT) ; Go off-list for Dx

 +1        NEW DIC,X,Y,TIUICD,TIUOUT

 +2        FOR 

               Begin DoDot:1

 +3                IF $LENGTH($TEXT(CONFIG^LEXSET))

                       Begin DoDot:2

 +4       ; Pass encounter date to LEXSET for CSV **161**

 +5       ; ICR 1609

                           DO CONFIG^LEXSET("ICD","ICD",TIUVDT)

                       End DoDot:2

                       IF 1

 +6               IF '$TEST

                       Begin DoDot:2

 +7                        WRITE !,$CHAR(7),"You must install LEXICON UTILITY v2.0 for this function to work...Contact IRM.",!

 +8       ; pause

                           IF $$READ^TIUU("EA","Press RETURN to continue...")

 +9                        SET TIUOUT=1

                       End DoDot:2

                       QUIT 

 +10               SET DIC(0)="AEMQ"

 +11               SET DIC("A")="Select "_$SELECT(+$GET(TIUICDAR(0))'>0:"Diagnosis: ",1:"Another Diagnosis"_$SELECT($DATA(TIUICDAR):" (NOT from Above List)",1:"")_": ")

 +12               NEW X

                   KILL DIC("B")

 +13               DO ^DIC

 +14               IF +$DATA(DTOUT)!+$DATA(DUOUT)!(X="")

                       SET TIUOUT=1

                       QUIT 

 +15               IF $GET(Y(1))]""

                       Begin DoDot:2

 +16      ;S TIUICD=+$O(^ICD9("AB",$P(Y(1),U)_" ",0))

 +17      ;ICR 3990

                           SET TIUICD=+$$CODEN^ICDCODE($PIECE(Y(1),U),80)

 +18      ;S:TIUICD'>0 TIUICD=+$O(^ICD9("AB",$P(Y(1),U)_"0 ",0))

 +19                       IF TIUICD'>0

                               SET TIUICD=+$$CODEN^ICDCODE($PIECE(Y(1),U)_"0",80)

 +20                       IF +TIUICD'>0

                               WRITE !,$CHAR(7),"ICD CODE NOT FOUND FOR EXPRESSION."

                               QUIT 

 +21                       IF $SELECT(+$GET(TIUI)'>0

                               SET TIUI=$GET(TIUI)+1

 +22                       SET TIUAICD(TIUI)=TIUICD_U_Y(1)_U_$PIECE(Y,U,2)

                       End DoDot:2

                       QUIT 

 +23               WRITE $CHAR(7),!!,"Nothing found for ",X,"..."

 +24               FOR 

                       Begin DoDot:2

 +25                       NEW X

 +26                       IF $LENGTH($TEXT(CONFIG^LEXSET))

                               Begin DoDot:3

 +27      ; Pass encounter date to LEXSET for CSV **161**

 +28                               DO CONFIG^LEXSET("ICD","ICD",TIUVDT)

                               End DoDot:3

                               IF 1

 +29                      IF '$TEST

                               Begin DoDot:3

 +30                               WRITE !,$CHAR(7),"You must install LEXICON UTILITY v2.0 for this function to work...Contact IRM.",!

 +31      ; pause