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