ORWPCE ; SLC/JM/REV - wrap calls to PCE and AICS ;Aug 28, 2023@15:52
;;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,606**;Dec 17, 1997;Build 3
;
; Reference to LOOK^LEXA, ^TMP("LEXFND",$J) in ICR #2950
; Reference to CONFIG^LEXSET, ^TMP("LEXSCH",$J) in ICR #1609
; Reference to DSELECT^GMPLENFM, ^TMP("IB",$J) in ICR #1365
; Reference to VLTD^ICDEX in ICR #5747
; Reference to CODEBA^ICDEX in ICR #5747
; Reference to GETLST^IBDF18A in ICR #1296
; Reference to $$ICDDESC^ICDXCODE in ICR #5699
; Reference to GETFIELD^PXAAVSIT in ICR #3048
; Reference to VSTRBLD^TIUSRVP in ICR #4075
; Reference to DOCCNT^TIUSRVLV in ICR #2812
; Reference to $$ISADDNDM^TIULC1 in ICR #2323
; Reference to SCCOND^PXUTLSCC in ICR #2348
; Reference to PRENDIAG^PXRMPDX in ICR #6991
; Reference to SVC^PXKCO in ICR #3225
; Reference to ENCEVENT^PXAPI in ICR #1894
; Reference to VST2APPT^PXAPI in ICR #1895
; Reference to $$GETENC^PXAPI in ICR #1894
; Reference to DELVFILE^PXAPI in ICR #1890
; Reference to ^TIU(8925, in ICR #2937
; Reference to ^DIC(31, in ICR #2967
; Reference to ^DG(391, in ICR #2966
;
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
; VSTR = Visit String
; DFN = Patient IEN (#2)
; VISIT = Visit IEN (#9000010)
;
; Must either pass in VISIT, or must pass in VSTR and DFN.
; It is best to pass in VISIT. VSTR and DFN are only included for backward compatability.
;
N ORCOUNT,ORVISITLIST
S VAL=0
I '$G(VISIT),('$G(DFN)!($G(VSTR)="")) Q
;
; CPRS can pass VISIT=-1 if the note being deleted did not reference a Visit
I $G(VISIT)<0 Q
;
I +$G(VISIT)=0 S VISIT=$$GETVSIT^ORWPCE1($G(VSTR),$G(DFN))
I VISIT'>0 Q
;
I $$GETFIELD^PXAAVSIT(VISIT,.07)="H" Q ; leave inpatient alone
;
; Do not delete if another title points to visit
D DOCCNT^TIUSRVLV(.ORCOUNT,"","",VISIT,1)
I ORCOUNT>0 Q
;
S VAL=$$DELVFILE^PXAPI("ALL",VISIT,"","TEXT INTEGRATION UTILITIES")
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 10908 printed Dec 13, 2024@02:36:58 Page 2
ORWPCE ; SLC/JM/REV - wrap calls to PCE and AICS ;Aug 28, 2023@15:52
+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,606**;Dec 17, 1997;Build 3
+2 ;
+3 ; Reference to LOOK^LEXA, ^TMP("LEXFND",$J) in ICR #2950
+4 ; Reference to CONFIG^LEXSET, ^TMP("LEXSCH",$J) in ICR #1609
+5 ; Reference to DSELECT^GMPLENFM, ^TMP("IB",$J) in ICR #1365
+6 ; Reference to VLTD^ICDEX in ICR #5747
+7 ; Reference to CODEBA^ICDEX in ICR #5747
+8 ; Reference to GETLST^IBDF18A in ICR #1296
+9 ; Reference to $$ICDDESC^ICDXCODE in ICR #5699
+10 ; Reference to GETFIELD^PXAAVSIT in ICR #3048
+11 ; Reference to VSTRBLD^TIUSRVP in ICR #4075
+12 ; Reference to DOCCNT^TIUSRVLV in ICR #2812
+13 ; Reference to $$ISADDNDM^TIULC1 in ICR #2323
+14 ; Reference to SCCOND^PXUTLSCC in ICR #2348
+15 ; Reference to PRENDIAG^PXRMPDX in ICR #6991
+16 ; Reference to SVC^PXKCO in ICR #3225
+17 ; Reference to ENCEVENT^PXAPI in ICR #1894
+18 ; Reference to VST2APPT^PXAPI in ICR #1895
+19 ; Reference to $$GETENC^PXAPI in ICR #1894
+20 ; Reference to DELVFILE^PXAPI in ICR #1890
+21 ; Reference to ^TIU(8925, in ICR #2937
+22 ; Reference to ^DIC(31, in ICR #2967
+23 ; Reference to ^DG(391, in ICR #2966
+24 ;
+25 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 ; VSTR = Visit String
+2 ; DFN = Patient IEN (#2)
+3 ; VISIT = Visit IEN (#9000010)
+4 ;
+5 ; Must either pass in VISIT, or must pass in VSTR and DFN.
+6 ; It is best to pass in VISIT. VSTR and DFN are only included for backward compatability.
+7 ;
+8 NEW ORCOUNT,ORVISITLIST
+9 SET VAL=0
+10 IF '$GET(VISIT)
IF ('$GET(DFN)!($GET(VSTR)=""))
QUIT
+11 ;
+12 ; CPRS can pass VISIT=-1 if the note being deleted did not reference a Visit
+13 IF $GET(VISIT)<0
QUIT
+14 ;
+15 IF +$GET(VISIT)=0
SET VISIT=$$GETVSIT^ORWPCE1($GET(VSTR),$GET(DFN))
+16 IF VISIT'>0
QUIT
+17 ;
+18 ; leave inpatient alone
IF $$GETFIELD^PXAAVSIT(VISIT,.07)="H"
QUIT
+19 ;
+20 ; Do not delete if another title points to visit
+21 DO DOCCNT^TIUSRVLV(.ORCOUNT,"","",VISIT,1)
+22 IF ORCOUNT>0
QUIT
+23 ;
+24 SET VAL=$$DELVFILE^PXAPI("ALL",VISIT,"","TEXT INTEGRATION UTILITIES")
+25 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
