TIUPXAPI ; SLC/JER - Interface w/PCE/Visit Tracking ;11/02/23 11:00
;;1.0;TEXT INTEGRATION UTILITIES;**15,24,29,82,107,126,161,267,263,357**;Jun 20, 1997;Build 5
;
; Reference to *^ICDEX supported by ICR #5747
;
Q
CREDIT(DFN,TIU,VSIT) ; Get Dx, CPT, (& SC) for the CMD's mandate
N TIUCPT,TIUAICD,TIUICDAR,TIUCPTAR,TIUSC,DTOUT,TIUOK,TIUPRLST,CSYSINFO
; 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)
S CSYSINFO=$$CSYSINFO(TIUVDT)
; *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,CSYSINFO) 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,CODENO,CODSYSNO,CSYS 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
. S CODENO=$P(TIUAICD(TIUI),U,2) S CSYS=$P($$CODECS^ICDEX(CODENO,80),U,2) ;ICR 5747
. S CODSYSNO="("_CSYS_" "_CODENO_") " W !?3,CODSYSNO
. I +$G(TIUAICD(TIUI,"PRIMARY")) D Q
. . I $L($P(TIUAICD(TIUI),U,3))+12<57 W ?22,$P(TIUAICD(TIUI),U,3)_" <<< PRIMARY" Q
. . W ?22,$E($P(TIUAICD(TIUI),U,3),1,57),!,?7,"<<< PRIMARY"
. W ?22,$E($P(TIUAICD(TIUI),U,3),1,57)
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 or 10 codes for clinic
N TIUI,TIUROW,TIUCOL,ARRY2,TIUITM,TIUPAGE,TIUCAT,INTFACE S TIUCAT=""
; Pass encounter date as the 5th parameter to IBDF18A **161**
S INTFACE="DG SELECT ICD DIAGNOSIS CODES"
D GETLST^IBDF18A(+TIULOC,INTFACE,"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,CSYSINFO) ; 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=+$$ICDDX^ICDEX($P(TIUICDAR("INDEX",+ITEM),U),$G(TIUVDT),+CSYSINFO,"E") ; *357
. . . 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,CSYSINFO)
Q:+$G(DTOUT)
; Pass encounter date to ICDOUT to pass to LEXSET for CSV **161**
E D ICDOUT(.TIUAICD,,TIUVDT,CSYSINFO)
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,CSYSINFO) ; Go off-list for Dx
N DIC,X,Y,TIUICD,TIUOUT,CSYSIEN,NSID,SSID,CODE
S CSYSIEN=+CSYSINFO,(NSID,SSID)=$P(CSYSINFO,U,2)
F D Q:+$G(TIUOUT)
. I $L($T(CONFIG^LEXSET)) D I 1
. . ; Pass encounter date to LEXSET for CSV **161**
. . S (NSID,SSID)=$P(CSYSINFO,U,2)
. . D CONFIG^LEXSET(NSID,SSID,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
. S CODE=$S(NSID="ICD":Y(1),NSID="10D":Y(30),1:"")
. I CODE]"" D Q ;Y(1 or 30)=DX CODE
. . S TIUICD=+$$ICDDX^ICDEX(CODE,$G(TIUVDT),CSYSIEN,"E") ; *357
. . 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_CODE_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(NSID,SSID,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("A")="Please try another expression, or RETURN to continue: "
. . D ^DIC
. . I +$D(DTOUT)!+$D(DUOUT)!(X="") S TIUOUT=1 Q
. . S CODE=$S(NSID="ICD":Y(1),NSID="10D":Y(30),1:"")
. . I CODE]"" D Q ;Y(1 or 30)=DX CODE
. . . S TIUICD=+$$ICDDX^ICDEX(CODE,$G(TIUVDT),CSYSIEN,"E") ; *357
. . . S:$S(+$G(TIUI)'>0:1,$D(TIUAICD(+$G(TIUI))):1,1:0) TIUI=$G(TIUI)+1
. . . S TIUAICD(TIUI)=TIUICD_U_CODE_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
;
CSYSINFO(DATE) ;Function: Coding system Information
; DATE is date of interest; defaults to today
; Returns CodesystemIENin757.3^AppNamespacein757.2^ImpDateofICD-10
N X,X1,X2,IMPDT,CSIEN,NOW
D NOW^%DTC S NOW=X K X
S DATE=$S($G(DATE)>0:DATE,1:NOW)
S X1=DATE,IMPDT=$$IMPDATE^LEXU("10D"),X2=IMPDT ; ICR 5679
D ^%DTC I X'<0 Q 30_"^10D^"_IMPDT
Q 1_"^ICD^"_IMPDT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPXAPI 10956 printed Apr 09, 2024@21:48:53 Page 2
TIUPXAPI ; SLC/JER - Interface w/PCE/Visit Tracking ;11/02/23 11:00
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**15,24,29,82,107,126,161,267,263,357**;Jun 20, 1997;Build 5
+2 ;
+3 ; Reference to *^ICDEX supported by ICR #5747
+4 ;
+5 QUIT
CREDIT(DFN,TIU,VSIT) ; Get Dx, CPT, (& SC) for the CMD's mandate
+1 NEW TIUCPT,TIUAICD,TIUICDAR,TIUCPTAR,TIUSC,DTOUT,TIUOK,TIUPRLST,CSYSINFO
+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 SET CSYSINFO=$$CSYSINFO(TIUVDT)
+6 ; *161 Pass encounter date to GETICD as 3rd and 4th variable, then to IBDF18A
+7 DO GETICD(TIU("LOC"),.TIUICDAR,TIUVDT)
ICDCALL ; **15**
DO ICD(.TIUAICD,.TIUICDAR,TIUVDT,CSYSINFO)
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
+5 ;
CONFIRM(TIUAICD,TIUCPT,TIUSC) ; Show user and confirm
+1 NEW TIUI,TIUY,CODENO,CODSYSNO,CSYS
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 ;ICR 5747
SET CODENO=$PIECE(TIUAICD(TIUI),U,2)
SET CSYS=$PIECE($$CODECS^ICDEX(CODENO,80),U,2)
+7 SET CODSYSNO="("_CSYS_" "_CODENO_") "
WRITE !?3,CODSYSNO
+8 IF +$GET(TIUAICD(TIUI,"PRIMARY"))
Begin DoDot:2
+9 IF $LENGTH($PIECE(TIUAICD(TIUI),U,3))+12<57
WRITE ?22,$PIECE(TIUAICD(TIUI),U,3)_" <<< PRIMARY"
QUIT
+10 WRITE ?22,$EXTRACT($PIECE(TIUAICD(TIUI),U,3),1,57),!,?7,"<<< PRIMARY"
End DoDot:2
QUIT
+11 WRITE ?22,$EXTRACT($PIECE(TIUAICD(TIUI),U,3),1,57)
End DoDot:1
+12 WRITE !!,"PROCEDURES:"
+13 SET TIUI=0
+14 FOR
SET TIUI=$ORDER(TIUCPT(TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+15 WRITE !?3,$PIECE(TIUCPT(TIUI),U,4),?12,$EXTRACT($PIECE(TIUCPT(TIUI),U,2),1,67)
+16 ;Display CPT Modifiers
+17 DO DISMOD^TIUPXAPM(.TIUCPT,TIUI)
End DoDot:1
+18 IF $DATA(TIUSC)>9
Begin DoDot:1
+19 WRITE !!,"SERVICE CONNECTION:"
+20 WRITE !?3,"Service Connected? ",$SELECT(+$GET(TIUSC("SC")):"YES",1:"NO")
+21 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")
+22 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")
+23 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")
+24 IF $DATA(TIUSC("MST"))
WRITE !?3,"MST? ",$SELECT($GET(TIUSC("MST"))]"":$PIECE($GET(TIUSC("MST")),U,2),1:"NOT ANSWERED")
+25 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
+26 WRITE !
SET TIUY=+$$READ^TIUU("Y"," ...OK","YES")
+27 QUIT +$GET(TIUY)
+28 ;
+29 ; Pass encounter date to GETICD to pass to IBDF18A **161**
GETICD(TIULOC,TIUICDAR,TIUVDT) ; Get ICD-9 or 10 codes for clinic
+1 NEW TIUI,TIUROW,TIUCOL,ARRY2,TIUITM,TIUPAGE,TIUCAT,INTFACE
SET TIUCAT=""
+2 ; Pass encounter date as the 5th parameter to IBDF18A **161**
+3 SET INTFACE="DG SELECT ICD DIAGNOSIS CODES"
+4 ;ICR 1296
DO GETLST^IBDF18A(+TIULOC,INTFACE,"ARRY2",,,,TIUVDT)
+5 SET (TIUI,TIUROW,TIUITM)=0
SET (TIUCOL,TIUPAGE)=1
+6 FOR
SET TIUI=$ORDER(ARRY2(TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+7 IF $PIECE(ARRY2(TIUI),U)]""
Begin DoDot:2
+8 SET TIUROW=+$GET(TIUROW)+1
SET TIUITM=+$GET(TIUITM)+1
+9 SET TIUICDAR(TIUROW,TIUCOL)=TIUITM_U_$GET(ARRY2(TIUI))_U_TIUCAT
+10 SET TIUICDAR("INDEX",TIUITM)=$GET(ARRY2(TIUI))_U_TIUCAT
KILL ARRY2(TIUI)
End DoDot:2
IF 1
+11 IF '$TEST
Begin DoDot:2
+12 SET TIUROW=+$GET(TIUROW)+1
SET TIUCAT=$$UP^XLFSTR($PIECE($GET(ARRY2(TIUI)),U,2))
+13 SET TIUICDAR(TIUROW,TIUCOL)=U_U_TIUCAT
+14 KILL ARRY2(TIUI)
End DoDot:2
+15 IF (TIUROW#20'>0)
IF (TIUCOL=3)
SET TIUPAGE=TIUPAGE+1
+16 IF TIUROW#20'>0
SET TIUCOL=$SELECT(TIUCOL=3:1,1:TIUCOL+1)
SET TIUROW=20*(TIUPAGE-1)
End DoDot:1
+17 IF +$GET(ARRY2(0))>0
Begin DoDot:1
+18 SET TIUROW=+$GET(TIUROW)+1
SET TIUITM=TIUITM+1
+19 SET TIUICDAR(TIUROW,TIUCOL)=TIUITM_"^OTHER ICD^OTHER Diagnosis"
+20 SET TIUICDAR("INDEX",TIUITM)="OTHER ICD^OTHER Diagnosis"
+21 SET TIUICDAR(0)=+$GET(ARRY2(0))_U_+$GET(TIUROW)_U_+$GET(TIUPAGE)
+22 IF (TIUROW#20'>0)
IF (TIUCOL=3)
SET TIUPAGE=TIUPAGE+1
+23 IF TIUROW#20'>0
SET TIUCOL=$SELECT(TIUCOL=3:1,1:TIUCOL+1)
SET TIUROW=20*(TIUPAGE-1)
End DoDot:1
+24 QUIT
+25 ; Pass encounter date as TIUVDT for CSV **161**
ICD(TIUAICD,TIUICDAR,TIUVDT,CSYSINFO) ; 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 ; *357
SET TIUICD=+$$ICDDX^ICDEX($PIECE(TIUICDAR("INDEX",+ITEM),U),$GET(TIUVDT),+CSYSINFO,"E")
+21 SET TIUAICD(TIUI)=TIUICD_U_$GET(TIUICDAR("INDEX",+ITEM))
End DoDot:3
+22 ; Pass encounter date to ICDOUT to pass to LEXSET for CSV **161**
+23 IF '$TEST
DO ICDOUT(.TIUAICD,.TIUI,TIUVDT,CSYSINFO)
End DoDot:2
if +$GET(DTOUT)
QUIT
End DoDot:1
IF 1
+24 if +$GET(DTOUT)
QUIT
+25 ; Pass encounter date to ICDOUT to pass to LEXSET for CSV **161**
+26 IF '$TEST
DO ICDOUT(.TIUAICD,,TIUVDT,CSYSINFO)
+27 IF +$ORDER(TIUAICD(1))
DO ASKPRMRY(.TIUAICD)
IF 1
+28 if +$GET(DTOUT)
QUIT
+29 IF '$TEST
IF $DATA(TIUAICD(1))
SET TIUAICD(1,"PRIMARY")=1
+30 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,CSYSINFO) ; Go off-list for Dx
+1 NEW DIC,X,Y,TIUICD,TIUOUT,CSYSIEN,NSID,SSID,CODE
+2 SET CSYSIEN=+CSYSINFO
SET (NSID,SSID)=$PIECE(CSYSINFO,U,2)
+3 FOR
Begin DoDot:1
+4 IF $LENGTH($TEXT(CONFIG^LEXSET))
Begin DoDot:2
+5 ; Pass encounter date to LEXSET for CSV **161**
+6 SET (NSID,SSID)=$PIECE(CSYSINFO,U,2)
+7 ; ICR 1609 ******
DO CONFIG^LEXSET(NSID,SSID,TIUVDT)
End DoDot:2
IF 1
+8 IF '$TEST
Begin DoDot:2
+9 WRITE !,$CHAR(7),"You must install LEXICON UTILITY v2.0 for this function to work...Contact IRM.",!
+10 ; pause
IF $$READ^TIUU("EA","Press RETURN to continue...")
+11 SET TIUOUT=1
End DoDot:2
QUIT
+12 SET DIC(0)="AEMQ"
+13 SET DIC("A")="Select "_$SELECT(+$GET(TIUICDAR(0))'>0:"Diagnosis: ",1:"Another Diagnosis"_$SELECT($DATA(TIUICDAR):" (NOT from Above List)",1:"")_": ")
+14 NEW X
KILL DIC("B")
+15 DO ^DIC
+16 IF +$DATA(DTOUT)!+$DATA(DUOUT)!(X="")
SET TIUOUT=1
QUIT
+17 SET CODE=$SELECT(NSID="ICD":Y(1),NSID="10D":Y(30),1:"")
+18 ;Y(1 or 30)=DX CODE
IF CODE]""
Begin DoDot:2
+19 ; *357
SET TIUICD=+$$ICDDX^ICDEX(CODE,$GET(TIUVDT),CSYSIEN,"E")
+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_CODE_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 ; ICR 1609
DO CONFIG^LEXSET(NSID,SSID,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 SET CODE=$SELECT(NSID="ICD":Y(1),NSID="10D":Y(30),1:"")
+37 ;Y(1 or 30)=DX CODE
IF CODE]""
Begin DoDot:3
+38 ; *357
SET TIUICD=+$$ICDDX^ICDEX(CODE,$GET(TIUVDT),CSYSIEN,"E")
+39 if $SELECT(+$GET(TIUI)'>0
SET TIUI=$GET(TIUI)+1
+40 SET TIUAICD(TIUI)=TIUICD_U_CODE_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
+5 ;
CSYSINFO(DATE) ;Function: Coding system Information
+1 ; DATE is date of interest; defaults to today
+2 ; Returns CodesystemIENin757.3^AppNamespacein757.2^ImpDateofICD-10
+3 NEW X,X1,X2,IMPDT,CSIEN,NOW
+4 DO NOW^%DTC
SET NOW=X
KILL X
+5 SET DATE=$SELECT($GET(DATE)>0:DATE,1:NOW)
+6 ; ICR 5679
SET X1=DATE
SET IMPDT=$$IMPDATE^LEXU("10D")
SET X2=IMPDT
+7 DO ^%DTC
IF X'<0
QUIT 30_"^10D^"_IMPDT
+8 QUIT 1_"^ICD^"_IMPDT
