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

ORWPCE.m

Go to the documentation of this file.
ORWPCE ;SLC/JM,REV - Wrap Calls to PCE and AICS ;04/26/2021
 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,173,190,195,215,243,295,280,306,361,385,398,377,476,539**;Dec 17, 1997;Build 41
 ;
 ; DBIA 2950   LOOK^LEXA          ^TMP("LEXFND",$J)
 ; DBIA 1609   CONFIG^LEXSET      ^TMP("LEXSCH",$J)
 ; DBIA 1365   DSELECT^GMPLENFM   ^TMP("IB",$J)
 ; DBIA 1296   GETLST^IBDF18A
 ; DBIA 5699   $$ICDDESC^ICDXCODE
 ;
 Q
VISIT(LST,CLINIC,ORDATE) ; get list of visit types for clinic
 S:'+$G(ORDATE) ORDATE=DT
 D GETLST^IBDF18A(CLINIC,"DG SELECT VISIT TYPE CPT PROCEDURES","LST",,,,ORDATE)
 Q
PROC(LST,CLINIC,ORDATE) ; get list of procedures for clinic P12 for CPTMods
 S:'+$G(ORDATE) ORDATE=DT
 D GETLST^IBDF18A(CLINIC,"DG SELECT CPT PROCEDURE CODES","LST",,,1,ORDATE)
 N IDX,MOD,CODES,FIRST S IDX=0
 F  S IDX=$O(LST(IDX)) Q:'+IDX  D
 . I LST(IDX)="" K LST(IDX) Q
 . S MOD=0,CODES="",FIRST=1
 . F  S MOD=$O(LST(IDX,"MODIFIER",MOD)) Q:(MOD="")  D
 . . I FIRST S FIRST=0
 . . E  S CODES=CODES_";"
 . . S CODES=CODES_LST(IDX,"MODIFIER",MOD)
 . K LST(IDX,"MODIFIER")
 . I 'FIRST S $P(LST(IDX),U,12)=CODES
 Q
CPTMODS(LST,ORCPTCOD,ORDATE) ;Return CPT Modifiers for a CPT Code
 N ORM,ORIDX,ORI,MODNAME
 S:'+$G(ORDATE) ORDATE=DT
 I +($$CODM^ICPTCOD(ORCPTCOD,$NA(ORM),0,ORDATE)),+$D(ORM) D
 . S ORIDX="",ORI=0
 . F  S ORIDX=$O(ORM(ORIDX)) Q:(ORIDX="")  D
 . . S ORI=ORI+1,MODNAME=$P(ORM(ORIDX),U,1)
 . . S LST(MODNAME_ORI)=$P(ORM(ORIDX),U,2)_U_MODNAME_U_ORIDX
 Q
GETMOD(MODINFO,ORMODIEN,ORDATE) ;Returns info for a specific CPT Modifier
 N ORDATA
 S:'+$G(ORDATE) ORDATE=DT
 S ORDATA=$$MOD^ICPTMOD(ORMODIEN,"I",ORDATE,1)
 I +ORDATA>0 S MODINFO=ORMODIEN_U_$P(ORDATA,U,3)_U_$P(ORDATA,U,2)
 Q
DIAG(LIST,CLINIC,ORDATE,ORDFN) ; get list of diagnoses for clinic AND prior encounter diagnoses if ORDFN passed
 S:'+$G(ORDATE) ORDATE=DT
 ; *498 ajb merge lists if needed from prior encounter and clinics
 N LST,ORCNT,CODE,CODEIEN,DATE,J,VISITIEN ; some variables left over by call below, cleaning up with *498
 ; LIST(0)=total # of entries returned by both calls
 I +$G(ORDFN) D  ; only get prior encounter diagnoses if ORDRN is passed in
 . S LIST(0)=$$PRENDIAG^PXRMPDX(ORDFN,"T-3Y",ORDATE,.LIST) I '+LIST(0) S LIST(0)=1
 . S LIST(1)=$$TITLE^XLFSTR(LIST(1))_" [Past 3 Years]"
 D GETLST^IBDF18A(CLINIC,"DG SELECT ICD DIAGNOSIS CODES","LST",,,,ORDATE)
 S ORCNT=0 F  S ORCNT=$O(LST(ORCNT)) Q:'+ORCNT  D
 . S LIST(0)=$G(LIST(0))+1
 . I $P(LST(ORCNT),U)]"" S $P(LST(ORCNT),U,10)=$$VLTD^ICDEX($$CODEBA^ICDEX($P(LST(ORCNT),U),80),DT)
 . S LIST(LIST(0))=LST(ORCNT)
 S LIST(0)=$O(LIST(""),-1) ; set to total amount
 Q
IMM(LST,CLINIC) ;get list of immunizations for clinic
 D GETLST^IBDF18A(CLINIC,"PX SELECT IMMUNIZATIONS","LST")
 Q
SK(LST,CLINIC) ;get list of skin test for clinic
 D GETLST^IBDF18A(CLINIC,"PX SELECT SKIN TESTS","LST")
 Q
HF(LST,CLINIC) ;get list of health factors for clinic
 D GETLST^IBDF18A(CLINIC,"PX SELECT HEALTH FACTORS","LST")
 Q
PED(LST,CLINIC) ;get list of education topices for clinic
 D GETLST^IBDF18A(CLINIC,"PX SELECT EDUCATION TOPICS","LST")
 Q
TRT(LST,CLINIC) ;get list of treatments for clinic
 D GETLST^IBDF18A(CLINIC,"PX SELECT TREATMENTS","LST")
 Q
XAM(LST,CLINIC) ;get list of exams for clinic
 D GETLST^IBDF18A(CLINIC,"PX SELECT EXAMS","LST")
 Q
ACTPROB(GLST,DFN,ORDATE) ;get list of patient's active problems
 N ORPROB,ORPROBIX,ORPRCNT,ORTXT,ORTXT1,ORCODSYS,ORCOD,ORDT,ORTRY,QTLTXT,SCD,ORDATA,GMPINDT,DIAGINC,ORIMPDT
 K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS")
 S:'+$G(ORDATE) ORDATE=DT
 S GMPINDT=ORDATE,ORIMPDT=$$IMPDATE^LEXU("10D")
 D DSELECT^GMPLENFM  ;DBIA 1365
 S ORPRCNT=0
 S ORPROBIX=0
 F  S ORPROBIX=$O(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)) Q:'ORPROBIX  D  ;DBIA 1365
 . I (ORDATE<ORIMPDT)&($P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",14)="10D") K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX) Q
 . S ORPROB=$P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3)
 . I $L(ORPROB)>255 S $P(ORPROB,U)=$E($P(ORPROB,U),1,245)
 . I $E(ORPROB,1)="$" S ORPROB=$E(ORPROB,2,255)
 . I '$D(ORPROB(ORPROB)) D
 .. S ORPROB(ORPROB)=""
 .. S ORPRCNT=ORPRCNT+1
 .. S $P(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX),"^",2,3)=ORPROB
 . E  K ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",ORPROBIX)
 S ^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS",0)=ORPRCNT
 S GLST=$NA(^TMP("IB",$J,"INTERFACES","GMP SELECT PATIENT ACTIVE PROBLEMS"))
 Q
SCSEL(VAL,DFN,ATM,LOC,VST) ; return SC conditions that may be selected
 ; VAL=SCallow^SCdflt;AOallow^AOdflt;IRallow^IRdflt;ECallow^ECdflt;
 ;     MSTallow^MSTdflt;HNCallow^HNCdflt;CVAllow^CVDflt;SHADAllow^SHADDflt
 N ORX,S S S=";"
 D SCCOND^PXUTLSCC(DFN,ATM,LOC,$G(VST),.ORX)
 S VAL=$G(ORX("SC"))_S_$G(ORX("AO"))_S_$G(ORX("IR"))_S_$G(ORX("EC"))_S_$G(ORX("MST"))_S_$G(ORX("HNC"))_S_$G(ORX("CV"))_S_$G(ORX("SHAD"))
 Q
SCDIS(LST,DFN) ; Return service connected % and rated disabilities
 N VAEL,VAERR,I,ILST,DIS,SC,X
 D ELIG^VADPT
 S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO")
 I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q
 S I=0,ILST=1 F  S I=$O(^DPT(DFN,.372,I)) Q:'I  S X=^(I,0) D
 . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS=""
 . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC")
 . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")"
 I ILST=1 S LST(2)="Rated Disabilities: NONE STATED"
 Q
CPTREQD(VAL,IEN) ; return 1 in VAL if note still needs a CPT code
 S VAL=+$P(^TIU(8925,IEN,0),U,11)
 Q
NOTEVSTR(VAL,IEN) ; return the VSTR^AUTHOR for a note
 N X0,X12,VISIT
 S IEN=+$G(IEN),VAL="" Q:'IEN
 S X12=$G(^TIU(8925,IEN,12)),VISIT=+$P(X12,U,7)
 I VISIT S VAL=$$VSTRBLD^TIUSRVP(VISIT)
 I 'VISIT D
 .S X0=$G(^TIU(8925,IEN,0)),VAL=$P(X12,U,11)_";"_$P(X0,U,7)_";"_$P(X0,U,13)
 .I $P(VAL,";",3)="H" S $P(VAL,";",2)=$P(X12,U),$P(VAL,";",3)="D"
 Q
HASVISIT(ORY,IEN,DFN,ORLOC,ORDTE) ;Has visit or is stand alone
 N ORVISIT
 S ORY=-1
 I +$G(IEN)>0 S ORVISIT=+$P($G(^TIU(8925,+IEN,0)),U,3)
 I +$G(ORVISIT)'>0 S ORVISIT=$$GETENC^PXAPI(DFN,ORDTE,ORLOC)
 I +$G(ORVISIT)>0 S ORY=$$VST2APPT^PXAPI(ORVISIT)
 Q
DELETE(VAL,VSTR,DFN) ; delete PCE info when deleting a note
 N VISIT,ORCOUNT,ORDTE,ORLOC
 N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK
 S ORLOC=$P(VSTR,";"),ORDTE=$P(VSTR,";",2)
 I '$D(^TMP("ORWPCE",$J,VSTR))&('$$GETENC^PXAPI(DFN,ORDTE,ORLOC)) S VAL=0 Q  ; no PCE data saved yet
 I $P(VSTR,";",3)="H" S VAL=0 Q           ; leave inpatient alone
 I $L($T(DOCCNT^TIUSRVLV))=0 S VAL=0 Q    ; leave if no tiu entry point
 D DOCCNT^TIUSRVLV(.ORCOUNT,DFN,VSTR)     ; Do not delete if another
 I ORCOUNT>0 S VAL=0 Q                    ; title points to visit
 I $$NOTASK=1 D DQDEL^ORWPCE1 Q
 S ZTIO="ORW/PXAPI RESOURCE",ZTRTN="DQDEL^ORWPCE1",ZTDTH=$H
 S (ZTSAVE("VSTR"),ZTSAVE("DFN"))="",ZTDESC="CPRS Delete Note/PCE"
 S ZTSYNC="ORW"_VSTR
 D ^%ZTLOAD I '$D(ZTSK) D DQDEL^ORWPCE1
 ;D DQDEL^ORWPCE1(.VAL,VSTR,DFN)
 Q
SAVE(RESULT,PCELIST,NOTEIEN,ORLOC) ; save PCE information
 N VSTR,GMPLUSER,HEADER
 N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSYNC,ZTSK
 S VSTR=$P(PCELIST(1),U,4) K ^TMP("ORWPCE",$J,VSTR)
 M ^TMP("ORWPCE",$J,VSTR)=PCELIST
 S GMPLUSER=$$CLINUSER^ORQQPL1(DUZ),NOTEIEN=+$G(NOTEIEN)
 I $$NOTASK=1 D  Q
 .;S HEADER="CPRS ERROR SAVING ENCOUNTER DATA"
 .;N $ES,$ET S $ET="D ERRHRLR^ORERRH(1,HEADER)"
 .D DQSAVE^ORWPCE1
 S ZTIO="ORW/PXAPI RESOURCE",ZTRTN="DQSAVE^ORWPCE1",ZTDTH=$H
 S ZTSAVE("PCELIST(")="",ZTDESC="Data from CPRS to PCE"
 S ZTSAVE("GMPLUSER")="",ZTSAVE("NOTEIEN")="",ZTSAVE("DUZ")=""
 I VSTR'["E" S ZTSYNC="ORW"_VSTR
 S ZTSAVE("ORLOC")=""
 D ^%ZTLOAD I '$D(ZTSK) D DQSAVE^ORWPCE1
 Q
LEX(LST,X,APP,ORDATE) ; return list after lexicon lookup
 N LEX,ILST,I,IEN,ORIMPDT
 S ORIMPDT=$$IMPDATE^LEXU("10D")
 S:APP="CPT" APP="CHP" ; LEX PATCH 10
 S:'+$G(ORDATE) ORDATE=DT
 I APP="ICD",(ORDATE'<ORIMPDT) S APP="10D"
 D CONFIG^LEXSET(APP,APP,ORDATE)  ;DBIA 1609
 I APP="CHP" D
 . ; Set the filter for CPT only using CS APIs - format is the same as for DIC("S")
 . S ^TMP("LEXSCH",$J,"FIL",0)="I $L($$CPTONE^LEXU(+Y,$G(ORDATE)))!($L($$CPCONE^LEXU(+Y,$G(ORDATE))))"  ;DBIA 1609
 . ; Set Applications Default Flag (Lexicon can not overwrite filter)
 . S ^TMP("LEXSCH",$J,"ADF",0)=1
 D LOOK^LEXA(X,APP,1,"",ORDATE)
 I '$D(LEX("LIST",1)) D  G LEXX
 . S LST(1)="-1^No matches found.^"_APP
 S LST(1)=LEX("LIST",1),ILST=1
 S (I,IEN)=""
 F  S I=$O(^TMP("LEXFND",$J,I)) Q:I=""  D  ;DBIA 2950
 .F  S IEN=$O(^TMP("LEXFND",$J,I,IEN)) Q:IEN=""  D
 ..S ILST=ILST+1,LST(ILST)=IEN_U_^TMP("LEXFND",$J,I,IEN)
LEXX K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J),^TMP("LEXSCH",$J),^TMP("LEXLE",$J)
 Q
LEXCODE(VAL,IEN,APP,ORDATE)     ; return code for a lexicon entry
 S VAL=""
 S:'+$G(ORDATE) ORDATE=DT
 I APP="ICD"!(APP="10D") S VAL=$$ONE^LEXU(IEN,ORDATE,APP)_U_$S(APP="ICD":"ICD-9-CM",1:"ICD-10-CM")
 I APP="CPT"!(APP="CHP") S VAL=$$CPTONE^LEXU(IEN,ORDATE)_U_"CPT-4"
 I $P(VAL,U)="",(APP="CHP") S VAL=$$CPCONE^LEXU(IEN,ORDATE)_U_"HCPCS"
 Q
ADDRES ; Add the ORW/PXAPI RESOURCE device
 N X
 S X=$$RES^XUDHSET("ORW/PXAPI RESOURCE",,5,"CPRS to PCE transactions")
 Q
GETSVC(NEWSVC,SVC,LOC,INP) ; Returns the correct Service Connected Category
 N DSS,ORWSVC
 S DSS=$P($G(^SC(+LOC,0)),U,7)
 Q:'+DSS
 M ORWSVC=SVC
 S NEWSVC=$$SVC^PXKCO(.ORWSVC,DSS,INP,LOC) ; DBIA #3225
 Q
ICDVER(RESULT,ORDT) ; Get ICD codeset version (i.e., ICD-9-CM or ICD-10-CM)
 S ORDT=+$G(ORDT) S:'ORDT ORDT=DT
 S RESULT="ICD^ICD-9-CM"
 G:'$L($T(IMPDATE^LEXU)) ICDVERX
 I +$$IMPDATE^LEXU("10D")'>ORDT S RESULT="10D^ICD-10-CM"
ICDVERX Q
I10IMPDT(RESULT) ; Get ICD-10 Implementation Date
 S RESULT=""
 G:'$L($T(IMPDATE^LEXU)) I10IMPX
 S RESULT=$$IMPDATE^LEXU("10D")
I10IMPX Q
 ;
NOTASK() ;
 I '$$PATCH^XPDUTL("PX*1.0*211") Q 0
 Q +$$GET^XPAR("ALL","OR PCE TASKING UPDATES OFF",1,"I")
 ;