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
IF $$READ^TIUU("EA","Press RETURN to continue...")
+32 SET TIUOUT=1
End DoDot:3
QUIT
+33 SET DIC("A")="Please try another expression, or RETURN to continue: "
+34 DO ^DIC
+35 IF +$DATA(DTOUT)!+$DATA(DUOUT)!(X="")
SET TIUOUT=1
QUIT
+36 IF +$GET(Y(1))>0
Begin DoDot:3
+37 ;S TIUICD=+$O(^ICD9("AB",$P(Y(1),U)_" ",0))
+38 SET TIUICD=+$$CODEN^ICDCODE($PIECE(Y(1),U),80)
+39 IF $SELECT(+$GET(TIUI)'>0
SET TIUI=$GET(TIUI)+1
+40 SET TIUAICD(TIUI)=TIUICD_U_Y(1)_U_$PIECE(Y,U,2)
End DoDot:3
QUIT
+41 WRITE $CHAR(7),!!,"Nothing found for ",X,"..."
End DoDot:2
IF (+Y>0)!+$GET(TIUOUT)
QUIT
End DoDot:1
IF +$GET(TIUOUT)
QUIT
+42 QUIT
PROVLIST(PROVLIST) ; Identify primary provider
+1 NEW PRIMARY,DFLT,DUOUT
SET DFLT=""
+2 WRITE !
+3 IF +$PIECE($GET(TIUPRM0),U,8)=0
QUIT
+4 IF +$PIECE($GET(TIUPRM0),U,8)=1
SET DFLT=$$DFLTDOC(+TIU("VLOC"))
+5 IF +DFLT=DUZ
SET PROVLIST(1,"NAME")=DUZ
SET PROVLIST(1,"PRIMARY")=1
QUIT
+6 IF +DFLT
SET DFLT=$PIECE(DFLT,U,2)
+7 IF DFLT']""
SET DFLT=$SELECT($$PROVIDER^TIUPXAP1(DUZ,DT):$$PERSNAME^TIULC1(DUZ),1:"")
ASKPR SET PRIMARY=+$$ASKDOC(DFLT)
+1 IF +PRIMARY'>0
QUIT
+2 IF '+$$PROVIDER^TIUPXAP1(PRIMARY,DT)
Begin DoDot:1
+3 WRITE !,$CHAR(7)," Selected user is not a known PROVIDER. Please choose another..."
End DoDot:1
GOTO ASKPR
+4 SET PROVLIST(1,"NAME")=DUZ
+5 IF PRIMARY=DUZ
SET PROVLIST(1,"PRIMARY")=1
+6 IF '$TEST
SET PROVLIST(2,"NAME")=PRIMARY
SET PROVLIST(2,"PRIMARY")=1
SET PROVLIST(1,"PRIMARY")=0
+7 QUIT
ASKDOC(DFLT) ; Call ^DIC to look-up provider
+1 NEW DIC,X,Y
+2 SET DIC=200
SET DIC(0)="AEMQ"
SET DIC("A")="Select PRIMARY PROVIDER: "
+3 IF $GET(DFLT)]""
SET DIC("B")=$GET(DFLT)
+4 DO ^DIC
+5 QUIT +Y
DFLTDOC(HLOC) ; Get the default Provider
+1 NEW PXBPMT,TIUPNM,Y
SET Y=""
+2 ; ICR 3152
DO PRV^PXBUTL2(HLOC)
+3 IF $DATA(PXBPMT("DEF"))
SET TIUPNM=$ORDER(PXBPMT("DEF",""))
SET Y=$ORDER(PXBPMT("DEF",TIUPNM,0))_U_TIUPNM
+4 QUIT Y
