Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: TIUPXAPI

TIUPXAPI.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to *^ICDEX supported by ICR #5747
  1. ;
  1. Q
  1. CREDIT(DFN,TIU,VSIT) ; Get Dx, CPT, (& SC) for the CMD's mandate
  1. N TIUCPT,TIUAICD,TIUICDAR,TIUCPTAR,TIUSC,DTOUT,TIUOK,TIUPRLST,CSYSINFO
  1. ; For Historical Visits, just QUEUE the PXAPI call and quit
  1. I $P(TIU("VSTR"),";",3)="E" D QUE^TIUPXAP1 Q
  1. ; If no Location, and not Historical Visit, then quit
  1. Q:+$G(TIU("VSTR"))'>0
  1. REENTER I $G(VALMAR)="^TMP(""TIUR"",$J)",$D(TIU("PNM")) D
  1. . W !!,"For ",$G(TIU("PNM"))," ",$G(TIU("PID"))," Visit on "
  1. . W $P($G(TIU("EDT")),U,2),"..."
  1. D PROVLIST(.TIUPRLST)
  1. N TIUVDT S TIUVDT=$P($G(TIU("VSTR")),";",2)
  1. S CSYSINFO=$$CSYSINFO(TIUVDT)
  1. ; *161 Pass encounter date to GETICD as 3rd and 4th variable, then to IBDF18A
  1. D GETICD(TIU("LOC"),.TIUICDAR,TIUVDT)
  1. ICDCALL D ICD(.TIUAICD,.TIUICDAR,TIUVDT,CSYSINFO) G:+$G(DTOUT) INSUFF ; **15**
  1. I '$D(TIUAICD),'$D(DTOUT) W !!,$C(7),"You MUST enter one or more Diagnoses." H 3 G ICDCALL
  1. K TIUICDAR ; **15**
  1. ; Pass encounter date to TIUPXAPC to pass to IBDF18A **161**
  1. D GETCPT^TIUPXAPC(TIU("LOC"),.TIUCPTAR,TIUVDT)
  1. ; Pass encounter date to TIUPXAPC,ICPTCOD,TIUPXAPM for CSV **161**
  1. CPTCALL D CPT^TIUPXAPC(.TIUCPT,.TIUCPTAR,TIUVDT) G:+$G(DTOUT) INSUFF
  1. I '$D(TIUCPT),'$D(DTOUT) W !!,$C(7),"You MUST enter one or more Procedures." H 3 G CPTCALL
  1. K TIUCPTAR ; **15**
  1. D SCASK^TIUPXAPS(.TIUSC,+DFN,.TIU)
  1. INSUFF I $D(DTOUT)!(+$O(TIUAICD(0))'>0)&(+$O(TIUCPT(0))'>0)&(+$O(TIUSC(0))'>0) D G POST
  1. . W !,$C(7),"Insufficient information for Workload Credit."
  1. . W !,"Missing information will have to be captured by another method."
  1. S TIUOK=$$CONFIRM(.TIUAICD,.TIUCPT,.TIUSC)
  1. I '+TIUOK D G REENTER
  1. . W !!,"Changes Discarded. Please Enter Corrected Workload Data..." H 3
  1. . K TIUAICD,TIUCPT,TIUSC,TIUICDAR,TIUCPTAR
  1. K TIUCPTAR,TIUICDAR
  1. W !!,"Posting Workload Credit..."
  1. POST N ICD,CPT,SC
  1. M ICD=TIUAICD,CPT=TIUCPT,SC=TIUSC
  1. D QUE^TIUPXAP1 ; Queue TIU/PXAPI RESOURCE
  1. W:'+$G(DTOUT) "Done."
  1. Q
  1. ;
  1. CONFIRM(TIUAICD,TIUCPT,TIUSC) ; Show user and confirm
  1. N TIUI,TIUY,CODENO,CODSYSNO,CSYS S TIUY=0
  1. W !!,"You have indicated the following data apply to this visit:",!
  1. W !,"DIAGNOSES:"
  1. S TIUI=0
  1. F S TIUI=$O(TIUAICD(TIUI)) Q:+TIUI'>0 D
  1. . S CODENO=$P(TIUAICD(TIUI),U,2) S CSYS=$P($$CODECS^ICDEX(CODENO,80),U,2) ;ICR 5747
  1. . S CODSYSNO="("_CSYS_" "_CODENO_") " W !?3,CODSYSNO
  1. . I +$G(TIUAICD(TIUI,"PRIMARY")) D Q
  1. . . I $L($P(TIUAICD(TIUI),U,3))+12<57 W ?22,$P(TIUAICD(TIUI),U,3)_" <<< PRIMARY" Q
  1. . . W ?22,$E($P(TIUAICD(TIUI),U,3),1,57),!,?7,"<<< PRIMARY"
  1. . W ?22,$E($P(TIUAICD(TIUI),U,3),1,57)
  1. W !!,"PROCEDURES:"
  1. S TIUI=0
  1. F S TIUI=$O(TIUCPT(TIUI)) Q:+TIUI'>0 D
  1. . W !?3,$P(TIUCPT(TIUI),U,4),?12,$E($P(TIUCPT(TIUI),U,2),1,67)
  1. . ;Display CPT Modifiers
  1. . D DISMOD^TIUPXAPM(.TIUCPT,TIUI)
  1. I $D(TIUSC)>9 D
  1. . W !!,"SERVICE CONNECTION:"
  1. . W !?3,"Service Connected? ",$S(+$G(TIUSC("SC")):"YES",1:"NO")
  1. . 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")
  1. . 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")
  1. . 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")
  1. . I $D(TIUSC("MST")) W !?3,"MST? ",$S($G(TIUSC("MST"))]"":$P($G(TIUSC("MST")),U,2),1:"NOT ANSWERED")
  1. . I $D(TIUSC("HNC")) W !?3,"Head and/or Neck Cancer? ",$S($G(TIUSC("HNC"))]"":$P($G(TIUSC("HNC")),U,2),1:"NOT ANSWERED")
  1. W ! S TIUY=+$$READ^TIUU("Y"," ...OK","YES")
  1. Q +$G(TIUY)
  1. ;
  1. ; Pass encounter date to GETICD to pass to IBDF18A **161**
  1. GETICD(TIULOC,TIUICDAR,TIUVDT) ; Get ICD-9 or 10 codes for clinic
  1. N TIUI,TIUROW,TIUCOL,ARRY2,TIUITM,TIUPAGE,TIUCAT,INTFACE S TIUCAT=""
  1. ; Pass encounter date as the 5th parameter to IBDF18A **161**
  1. S INTFACE="DG SELECT ICD DIAGNOSIS CODES"
  1. D GETLST^IBDF18A(+TIULOC,INTFACE,"ARRY2",,,,TIUVDT) ;ICR 1296
  1. S (TIUI,TIUROW,TIUITM)=0,(TIUCOL,TIUPAGE)=1
  1. F S TIUI=$O(ARRY2(TIUI)) Q:+TIUI'>0 D
  1. . I $P(ARRY2(TIUI),U)]"" D I 1
  1. . . S TIUROW=+$G(TIUROW)+1,TIUITM=+$G(TIUITM)+1
  1. . . S TIUICDAR(TIUROW,TIUCOL)=TIUITM_U_$G(ARRY2(TIUI))_U_TIUCAT
  1. . . S TIUICDAR("INDEX",TIUITM)=$G(ARRY2(TIUI))_U_TIUCAT K ARRY2(TIUI)
  1. . E D
  1. . . S TIUROW=+$G(TIUROW)+1,TIUCAT=$$UP^XLFSTR($P($G(ARRY2(TIUI)),U,2))
  1. . . S TIUICDAR(TIUROW,TIUCOL)=U_U_TIUCAT
  1. . . K ARRY2(TIUI)
  1. . I (TIUROW#20'>0),(TIUCOL=3) S TIUPAGE=TIUPAGE+1
  1. . I TIUROW#20'>0 S TIUCOL=$S(TIUCOL=3:1,1:TIUCOL+1),TIUROW=20*(TIUPAGE-1)
  1. I +$G(ARRY2(0))>0 D
  1. . S TIUROW=+$G(TIUROW)+1,TIUITM=TIUITM+1
  1. . S TIUICDAR(TIUROW,TIUCOL)=TIUITM_"^OTHER ICD^OTHER Diagnosis"
  1. . S TIUICDAR("INDEX",TIUITM)="OTHER ICD^OTHER Diagnosis"
  1. . S TIUICDAR(0)=+$G(ARRY2(0))_U_+$G(TIUROW)_U_+$G(TIUPAGE)
  1. . I (TIUROW#20'>0),(TIUCOL=3) S TIUPAGE=TIUPAGE+1
  1. . I TIUROW#20'>0 S TIUCOL=$S(TIUCOL=3:1,1:TIUCOL+1),TIUROW=20*(TIUPAGE-1)
  1. Q
  1. ; Pass encounter date as TIUVDT for CSV **161**
  1. ICD(TIUAICD,TIUICDAR,TIUVDT,CSYSINFO) ; Select Dx's
  1. N TIUI,J,L,Y,TIUICD,TIUICNT,TIUPGS,TIUPG,TIUITM,TIULITM,TIUPNM
  1. S TIUPNM=$S($L($G(TIU("PNM"))):$G(TIU("PNM")),+$G(DFN):$$PTNAME^TIULC1(DFN),1:"the Patient")
  1. W !!,"Please Indicate the Diagnoses for which "_TIUPNM_" was Seen:"
  1. W:+$O(TIUICDAR(0)) !
  1. S TIUICNT=+$G(TIUICDAR(0)),TIUPGS=$P($G(TIUICDAR(0)),U,3)
  1. S (TIUI,J,L,Y)=0 I +TIUICNT S TIUPG=1
  1. F S TIUI=$O(TIUICDAR(TIUI)) Q:+TIUI'>0 D Q:+$G(DTOUT)
  1. . S J=0 W ! F S J=$O(TIUICDAR(TIUI,J)) Q:+J'>0 D
  1. . . 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)
  1. . . S TIUITM=$S(+$G(TIUICDAR(TIUI,J)):+$G(TIUICDAR(TIUI,J)),1:$G(TIUITM))
  1. . . S:TIUITM>+$G(TIULITM) TIULITM=TIUITM
  1. . 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 !
  1. . S L=TIUI S:TIUITM>+$G(TIULITM) TIULITM=TIUITM
  1. I +$G(DTOUT) Q
  1. I L#20 S Y=$S(+Y:Y,1:"")_$P($$PICK^TIUPXAP2(1,TIULITM,"Select Diagnoses"),U)
  1. I +Y,$P(TIUICDAR("INDEX",+Y),U)'="OTHER ICD" D I 1
  1. . N TIUI,ITEM F TIUI=1:1:($L(Y,",")-1) D Q:+$G(DTOUT)
  1. . . S ITEM=$P(Y,",",TIUI)
  1. . . I $P(TIUICDAR("INDEX",+ITEM),U)'="OTHER ICD" D
  1. . . . S TIUICD=+$$ICDDX^ICDEX($P(TIUICDAR("INDEX",+ITEM),U),$G(TIUVDT),+CSYSINFO,"E") ; *357
  1. . . . S TIUAICD(TIUI)=TIUICD_U_$G(TIUICDAR("INDEX",+ITEM))
  1. . . ; Pass encounter date to ICDOUT to pass to LEXSET for CSV **161**
  1. . . E D ICDOUT(.TIUAICD,.TIUI,TIUVDT,CSYSINFO)
  1. Q:+$G(DTOUT)
  1. ; Pass encounter date to ICDOUT to pass to LEXSET for CSV **161**
  1. E D ICDOUT(.TIUAICD,,TIUVDT,CSYSINFO)
  1. I +$O(TIUAICD(1)) D ASKPRMRY(.TIUAICD) I 1
  1. Q:+$G(DTOUT)
  1. E I $D(TIUAICD(1)) S TIUAICD(1,"PRIMARY")=1
  1. Q
  1. ASKPRMRY(TIUAICD) ; Which Dx is Primary
  1. N TIUI,L,Y
  1. PRMAGN W !!,"Please indicate which of the Diagnoses is the Primary Diagnosis:",!
  1. S (TIUI,L,Y)=0 F S TIUI=$O(TIUAICD(TIUI)) Q:+TIUI'>0!+Y D
  1. . W:$P(TIUAICD(TIUI),U)]"" !,TIUI,?7,$P(TIUAICD(TIUI),U,3)
  1. . I TIUI#20=0 S Y=$P($$PICK^TIUPXAP2(1,TIUI,"Select Diagnosis","NO"),U)
  1. . S L=TIUI
  1. I L#20,'+Y S Y=$P($$PICK^TIUPXAP2(1,L,"Select Diagnosis","NO"),U)
  1. I +Y'>0 W !!?3,$C(7),"You must specify a Primary Diagnosis." G PRMAGN
  1. I +Y,$D(TIUAICD(+Y)) S TIUAICD(+Y,"PRIMARY")=1
  1. Q
  1. ICDOUT(TIUAICD,TIUI,TIUVDT,CSYSINFO) ; Go off-list for Dx
  1. N DIC,X,Y,TIUICD,TIUOUT,CSYSIEN,NSID,SSID,CODE
  1. S CSYSIEN=+CSYSINFO,(NSID,SSID)=$P(CSYSINFO,U,2)
  1. F D Q:+$G(TIUOUT)
  1. . I $L($T(CONFIG^LEXSET)) D I 1
  1. . . ; Pass encounter date to LEXSET for CSV **161**
  1. . . S (NSID,SSID)=$P(CSYSINFO,U,2)
  1. . . D CONFIG^LEXSET(NSID,SSID,TIUVDT) ; ICR 1609 ******
  1. . E D Q
  1. . . W !,$C(7),"You must install LEXICON UTILITY v2.0 for this function to work...Contact IRM.",!
  1. . . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1. . . S TIUOUT=1
  1. . S DIC(0)="AEMQ"
  1. . S DIC("A")="Select "_$S(+$G(TIUICDAR(0))'>0:"Diagnosis: ",1:"Another Diagnosis"_$S($D(TIUICDAR):" (NOT from Above List)",1:"")_": ")
  1. . N X K DIC("B")
  1. . D ^DIC
  1. . I +$D(DTOUT)!+$D(DUOUT)!(X="") S TIUOUT=1 Q
  1. . S CODE=$S(NSID="ICD":Y(1),NSID="10D":Y(30),1:"")
  1. . I CODE]"" D Q ;Y(1 or 30)=DX CODE
  1. . . S TIUICD=+$$ICDDX^ICDEX(CODE,$G(TIUVDT),CSYSIEN,"E") ; *357
  1. . . I +TIUICD'>0 W !,$C(7),"ICD CODE NOT FOUND FOR EXPRESSION." Q
  1. . . S:$S(+$G(TIUI)'>0:1,$D(TIUAICD(+$G(TIUI))):1,1:0) TIUI=$G(TIUI)+1
  1. . . S TIUAICD(TIUI)=TIUICD_U_CODE_U_$P(Y,U,2)
  1. . W $C(7),!!,"Nothing found for ",X,"..."
  1. . F D Q:(+Y>0)!+$G(TIUOUT)
  1. . . N X
  1. . . I $L($T(CONFIG^LEXSET)) D I 1
  1. . . . ; Pass encounter date to LEXSET for CSV **161**
  1. . . . D CONFIG^LEXSET(NSID,SSID,TIUVDT) ; ICR 1609
  1. . . E D Q
  1. . . . W !,$C(7),"You must install LEXICON UTILITY v2.0 for this function to work...Contact IRM.",!
  1. . . . I $$READ^TIUU("EA","Press RETURN to continue...") ; pause
  1. . . . S TIUOUT=1
  1. . . S DIC("A")="Please try another expression, or RETURN to continue: "
  1. . . D ^DIC
  1. . . I +$D(DTOUT)!+$D(DUOUT)!(X="") S TIUOUT=1 Q
  1. . . S CODE=$S(NSID="ICD":Y(1),NSID="10D":Y(30),1:"")
  1. . . I CODE]"" D Q ;Y(1 or 30)=DX CODE
  1. . . . S TIUICD=+$$ICDDX^ICDEX(CODE,$G(TIUVDT),CSYSIEN,"E") ; *357
  1. . . . S:$S(+$G(TIUI)'>0:1,$D(TIUAICD(+$G(TIUI))):1,1:0) TIUI=$G(TIUI)+1
  1. . . . S TIUAICD(TIUI)=TIUICD_U_CODE_U_$P(Y,U,2)
  1. . . W $C(7),!!,"Nothing found for ",X,"..."
  1. Q
  1. PROVLIST(PROVLIST) ; Identify primary provider
  1. N PRIMARY,DFLT,DUOUT S DFLT=""
  1. W !
  1. I +$P($G(TIUPRM0),U,8)=0 Q
  1. I +$P($G(TIUPRM0),U,8)=1 S DFLT=$$DFLTDOC(+TIU("VLOC"))
  1. I +DFLT=DUZ S PROVLIST(1,"NAME")=DUZ,PROVLIST(1,"PRIMARY")=1 Q
  1. I +DFLT S DFLT=$P(DFLT,U,2)
  1. S:DFLT']"" DFLT=$S($$PROVIDER^TIUPXAP1(DUZ,DT):$$PERSNAME^TIULC1(DUZ),1:"")
  1. ASKPR S PRIMARY=+$$ASKDOC(DFLT)
  1. I +PRIMARY'>0 Q
  1. I '+$$PROVIDER^TIUPXAP1(PRIMARY,DT) D G ASKPR
  1. . W !,$C(7)," Selected user is not a known PROVIDER. Please choose another..."
  1. S PROVLIST(1,"NAME")=DUZ
  1. I PRIMARY=DUZ S PROVLIST(1,"PRIMARY")=1
  1. E S PROVLIST(2,"NAME")=PRIMARY,PROVLIST(2,"PRIMARY")=1,PROVLIST(1,"PRIMARY")=0
  1. Q
  1. ASKDOC(DFLT) ; Call ^DIC to look-up provider
  1. N DIC,X,Y
  1. S DIC=200,DIC(0)="AEMQ",DIC("A")="Select PRIMARY PROVIDER: "
  1. I $G(DFLT)]"" S DIC("B")=$G(DFLT)
  1. D ^DIC
  1. Q +Y
  1. DFLTDOC(HLOC) ; Get the default Provider
  1. N PXBPMT,TIUPNM,Y S Y=""
  1. D PRV^PXBUTL2(HLOC) ; ICR 3152
  1. I $D(PXBPMT("DEF")) S TIUPNM=$O(PXBPMT("DEF","")),Y=$O(PXBPMT("DEF",TIUPNM,0))_U_TIUPNM
  1. Q Y
  1. ;
  1. CSYSINFO(DATE) ;Function: Coding system Information
  1. ; DATE is date of interest; defaults to today
  1. ; Returns CodesystemIENin757.3^AppNamespacein757.2^ImpDateofICD-10
  1. N X,X1,X2,IMPDT,CSIEN,NOW
  1. D NOW^%DTC S NOW=X K X
  1. S DATE=$S($G(DATE)>0:DATE,1:NOW)
  1. S X1=DATE,IMPDT=$$IMPDATE^LEXU("10D"),X2=IMPDT ; ICR 5679
  1. D ^%DTC I X'<0 Q 30_"^10D^"_IMPDT
  1. Q 1_"^ICD^"_IMPDT