- 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 Feb 19, 2025@00:11:16 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