ORQQPL3 ; ALB/PDR,REV,ISL/JER/TC - Problem List RPCs ;02/13/17 14:04
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,148,173,243,280,306,361,385,429**;Dec 17, 1997;Build 33
;
; External References:
; $$ICDDESC^GMPLUTL2 ICR #2741
; $$PROBTEXT^GMPLX ICR #2742
; $$CODECS/$$CSI/$$ICDDX/$$SAB/$$STATCHK^ICDEX ICR #5747
; $$ICDDATA/$$STATCHK^ICDXCODE ICR #5699
; $$STATCHK^LEXSRC2 ICR #4083
; $$IMPDATE^LEXU ICR #5679
; $$DT^XLFDT ICR #10103
; $$GET^XPAR ICR #2263
;
;---------------- LIST PATIENT PROBLEMS ------------------------
;
PROBL(ROOT,DFN,CONTEXT,ORIDT) ; GET LIST OF PATIENT PROBLEMS
N DIWL,DIWR,DIWF
N ST,ORI,ORX
S ORIDT=$G(ORIDT,DT)
S (LCNT,NUM)=0
S DIWL=1,DIWR=48,DIWF="C48"
S CONTEXT=";;"_$G(CONTEXT)
I CONTEXT=";;" S CONTEXT=";;A"
S ST=$P(CONTEXT,";",3)
;
I ST="R" D DELLIST(.ROOT,+DFN,ORIDT) ; show deleted only
I ST'="R" D LIST(.ROOT,+DFN,ST,ORIDT) ; show others - don't trust ELSE here
;
I ROOT(0)<1 D
. S LCNT=1
. S ROOT(1)=" "_$$PAD^ORCHTAB("No data available.",49)_"|"
Q
;
;
LIST(GMPL,GMPDFN,GMPSTAT,ORIDT) ; -- Returns list of problems for patient GMPDFN
; in GMPL(#)=ifn^status^description^ICD^onset^last modified^SC^SpExp^Condition^Loc^
; loc.type^prov^service^priority^has comment^date recorded^SC condition(s)^
; inactive flag^ICD long description^ICD coding system
; & GMPL(0)=number of problems returned
; This is virtually same as LIST^GMPLUTL2 except that it appends the
; condition - T)ranscribed or P)ermanent,location,loc type,provider, service.
;
N CNT,SP,NUM,ORLIST,ORVIEW,GMPARAM,IMPLDT
Q:$G(GMPDFN)'>0
S IMPLDT=$$IMPDATE^LEXU("10D")
S ORIDT=$G(ORIDT,DT)
S:ORIDT=0 ORIDT=DT
S CNT=0,SP=""
S GMPARAM("QUIET")=1
S GMPARAM("REV")=$P($G(^GMPL(125.99,1,0)),U,5)="R"
S ORVIEW("ACT")=GMPSTAT
S ORVIEW("PROV")=0
S ORVIEW("VIEW")=""
;
D GETPLIST^GMPLMGR1(.ORLIST,.ORTOTAL,.ORVIEW)
;
F NUM=0:0 S NUM=$O(ORLIST(NUM)) Q:NUM'>0 D
. N GMPL0,GMPL1,GMPL800,GMPL802,I,IFN,SCT,ST,ONSET,ICD,LASTMOD,PRIO,DTREC,ICDD,ORDTINT,ORPLCSYS
. N SC,ORTOTAL,LIN,LOC,LT,PROV,SERV,HASCMT,SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,INACT
. S IFN=+ORLIST(NUM) Q:IFN'>0
. S (ICDD,INACT)=""
. S GMPL0=$G(^AUPNPROB(IFN,0))
. S GMPL1=$G(^AUPNPROB(IFN,1))
. S GMPL800=$G(^AUPNPROB(IFN,800)),SCT=$P(GMPL800,U)
. S GMPL802=$G(^AUPNPROB(IFN,802))
. S HASCMT=($D(^AUPNPROB(IFN,11,0))>0)
. S CNT=CNT+1
. N LEX
. S ORDTINT=$S(+$P(GMPL802,U,1):$P(GMPL802,U,1),1:$P(GMPL0,U,8))
. S ORPLCSYS=$S($P(GMPL802,U,2)]"":$P(GMPL802,U,2),1:$$SAB^ICDEX($$CSI^ICDEX(80,+GMPL0),ORDTINT))
. S ICD=$P($$ICDDATA^ICDXCODE(ORPLCSYS,+GMPL0,ORDTINT,"I"),U,2)
. I (ORIDT<IMPLDT),(+$$STATCHK^ICDXCODE($$CSI^ICDEX(80,+GMPL0),ICD,ORIDT)'=1) S INACT="#"
. I +$G(SCT),(+$$STATCHK^LEXSRC2(SCT,ORIDT,.LEX)'=1) S INACT="$"
. I $D(^AUPNPROB(IFN,803)) D
. . N I S I=0
. . F S I=$O(^AUPNPROB(IFN,803,I)) Q:+I'>0 S $P(ICD,"/",(I+1))=$P($G(^AUPNPROB(IFN,803,I,0)),U)
. I +SCT'>0,(+ICD>0) S ICDD=$$ICDDESC^GMPLUTL2(ICD,ORIDT,ORPLCSYS)
. S LASTMOD=$P(GMPL0,U,3)
. S ST=$P(GMPL0,U,12)
. S ONSET=$P(GMPL0,U,13)
. S SC=$S(+$P(GMPL1,U,10):"SC",$P(GMPL1,U,10)=0:"NSC",1:"")
. S AO=$S(+$P(GMPL1,U,11):"/AO",1:"")
. S IR=$S(+$P(GMPL1,U,12):"/IR",1:"")
. S ENV=$S(+$P(GMPL1,U,13):"/EC",1:"")
. S HNC=$S(+$P(GMPL1,U,15):"/HNC",1:"")
. S MST=$S(+$P(GMPL1,U,16):"/MST",1:"")
. S CV=$S(+$P(GMPL1,U,17):"/CV",1:"")
. S SHD=$S(+$P(GMPL1,U,18):"/SHD",1:"")
. S SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD
. S LOC=$P(GMPL1,U,8)
. S DTREC=$P(GMPL1,U,9)
. S LT=""
. I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3),LOC=LOC_";"_$P($G(^SC(LOC,0)),U,1)
. S PROV=$P(GMPL1,U,5) ; responsible provider
. I PROV'="" S PROV=PROV_";"_$P($G(^VA(200,PROV,0)),U,1)
. S SERV=$P(GMPL1,U,6)
. I SERV=0 S SERV="" ; not sure how it gets set to 0, but need consistency in GUI
. I SERV'="" S SERV=SERV_";"_$P($G(^DIC(49,SERV,0)),U,1)
. S SP=""
. F I=11,12,13 S:$P(GMPL1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P")
. S PRIO=$P(GMPL1,U,14)
. S LIN=IFN_U_ST_U_$$PROBTEXT^GMPLX(IFN)_U_ICD_U_ONSET
. S LIN=LIN_U_LASTMOD_U_SC_U_SP_U_$P(GMPL1,U,2)
. S LIN=LIN_U_LOC_U_LT_U_PROV_U_SERV_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT_U_ICDD_U_ORPLCSYS
. S GMPL(CNT)=LIN
S GMPL(0)=CNT
Q
;
;
;------------------------ GET LIST OF DELETED PROBLEMS -----------------------------
;
DELLIST(RETURN,GMPDFN,ORIDT) ; GET LIST OF DELETED PROBLEMS
; see GETPLIST^GMPLMGR1 and LIST^GMPUTL2
N S,I,IMPLDT
S IMPLDT=$$IMPDATE^LEXU("10D")
S ORIDT=$G(ORIDT,DT)
S:ORIDT=0 ORIDT=DT
S I=0,S=""
F S S=$O(^AUPNPROB("ACTIVE",GMPDFN,S)) Q:S="" D
. N IFN,L0,L1,L800,L802,SCT,ST,TXT,ICD,ONSET,MOD,SC,SP,LOC,LT,PROV,SERV,PRIO,HASCMT,DTREC
. N SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,INACT,ORPLCSYS,ICDD,ORDTINT
. S IFN=""
. F S IFN=$O(^AUPNPROB("ACTIVE",+GMPDFN,S,IFN)) Q:IFN="" D
.. I $P($G(^AUPNPROB(IFN,1)),U,2)="H" D
... S L0=$G(^AUPNPROB(IFN,0))
... S L800=$G(^AUPNPROB(IFN,800)),SCT=$P(L800,U)
... S L802=$G(^AUPNPROB(IFN,802))
... Q:L0=""
... S (ICDD,INACT)=""
... S L1=$G(^AUPNPROB(IFN,1))
... S ST=$P(L0,U,12)
... S TXT=$$PROBTEXT^GMPLX(IFN)
... S ORDTINT=$S(+$P(L802,U,1):$P(L802,U,1),1:$P(L0,U,8))
... S ORPLCSYS=$S($P(L802,U,2)]"":$P(L802,U,2),1:$$SAB^ICDEX($$CSI^ICDEX(80,+L0),ORDTINT))
... S ICD=$P($$ICDDATA^ICDXCODE(ORPLCSYS,+L0,ORDTINT,"I"),U,2)
... I (ORIDT<IMPLDT),(+$$STATCHK^ICDXCODE($$CSI^ICDEX(80,+L0),ICD,ORIDT)'=1) S INACT="#"
... I +SCT'>0,(+ICD>0) S ICDD=$$ICDDESC^GMPLUTL2(ICD,ORIDT,ORPLCSYS)
... S ONSET=$P(L0,U,13)
... S MOD=$P(L0,U,3)
... S SC=$S(+$P(L1,U,10):"SC",$P(L1,U,10)=0:"NSC",1:"")
... S AO=$S(+$P(L1,U,11):"/AO",1:"")
... S IR=$S(+$P(L1,U,12):"/IR",1:"")
... S ENV=$S(+$P(L1,U,13):"/EC",1:"")
... S HNC=$S(+$P(L1,U,15):"/HNC",1:"")
... S MST=$S(+$P(L1,U,16):"/MST",1:"")
... S CV=$S(+$P(L1,U,17):"/CV",1:"")
... S SHD=$S(+$P(L1,U,18):"/SHD",1:"")
... S SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD
... S SP=$$GETSP
... S LOC=$P(L1,U,8)
... S LT=""
... I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3)
... S PROV=$P(L1,U,5) ; responsible provider
... S SERV=$P(L1,U,6)
... S PRIO=$P(L1,U,14)
... S HASCMT=($D(^AUPNPROB(IFN,11,0))>0)
... S DTREC=$P(L1,U,9)
... S I=I+1
... S RETURN(I)=IFN_U_ST_U_TXT_U_ICD_U_ONSET
... S RETURN(I)=RETURN(I)_U_MOD_U_SC_U_SP_U_$P(L1,U,2)
... S RETURN(I)=RETURN(I)_U_LOC_U_LT_U_PROV_U_SERV
... S RETURN(I)=RETURN(I)_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT_U_ICDD_U_ORPLCSYS
S RETURN(0)=I
Q
;
GETSP() ; GET EXPOSURES
N I
S SP=""
F I=11,12,13 S:$P(L1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P")
Q SP
;
; adapted from ^GMPLBLD3 ;9/96
;
; ----------------------- GET USER PROBLEM CATEGORIES --------------
;
CAT(ORTMP,ORDUZ,ORCLIN) ; Get user category list
N ORGSEQ,ORGCNT,ORGROUP,ORHDR,ORIFN,ORLCNT,ORITEM,ORTG,ORSLST
S ORTG=$NAME(ORTMP) ; put list in local
K @ORTG
S (ORGSEQ,ORGCNT,ORLCNT)=0
;
S ORSLST=$$GET^XPAR("USR^LOC.`"_ORCLIN_"^DIV^SYS^PKG","ORQQPL SELECTION LIST",1) ; get approp default list
; Build multiple of category\problems
; Iterate categories
F S ORGSEQ=$O(^GMPL(125,"AD",+ORSLST,ORGSEQ)) Q:ORGSEQ'>0 D
. S ORIFN=$O(^GMPL(125,"AD",+ORSLST,ORGSEQ,0)) Q:ORIFN'>0
. S ORITEM=$G(^GMPL(125,+ORSLST,1,ORIFN,0))
. S ORGROUP=+$P(ORITEM,U,1)
. S ORHDR=ORGROUP_U_$P(ORITEM,U,3,4)
. S ORGCNT=ORGCNT+1
. S @ORTG@(ORGCNT)=ORHDR ; put category into temp global
Q
;
;----------------------- USER PROBLEM LIST --------------------------
;
PROB(TMP,ORGROUP) ; Get user problem list for given group
N ORPSEQ,ORPCNT,ORIFN,ORITEM,ORTG,ORICD,ORTEXT,ORPLCSYS,ORPLCPTR,ORDT,ORSCTC,ORLCNT
S ORTG=$NAME(TMP) ; put list in local
K @ORTG
S ORLCNT=0
;
; iterate through problems in category
S (ORPSEQ,ORPCNT)=0,ORDT=$$DT^XLFDT
F S ORPSEQ=$O(^GMPL(125.11,"C",ORGROUP,ORPSEQ)) Q:ORPSEQ'>0 D
. N ORI,ORK,ORQUIT S ORQUIT=0
. S ORIFN=$O(^GMPL(125.11,"C",ORGROUP,ORPSEQ,0)) Q:ORIFN'>0
. S ORITEM=$G(^GMPL(125.11,ORGROUP,1,ORIFN,0))
. S ORTEXT=$P(ORITEM,U,3),ORICD=$P(ORITEM,U,4)
. S ORSCTC=$P(ORITEM,U,5)
. ; exclude any problems w/inactive SNOMED codes
. I $L(ORSCTC) D
. . I '$$STATCHK^LEXSRC2(ORSCTC,ORDT,"","SCT") S ORQUIT=1 Q
. ; if any ICD codes inactive, exclude from list
. I $L(ORICD)&(ORICD["/") D
. . F ORK=1:1:$L(ORICD,"/") Q:+ORQUIT D
. . . S ORPLCPTR=+$$CODECS^ICDEX($P(ORICD,"/",ORK),80,ORDT),ORPLCSYS=$$SAB^ICDEX(ORPLCPTR,ORDT)
. . . I '+$$STATCHK^ICDEX($P(ORICD,"/",ORK),ORDT,ORPLCPTR) S ORQUIT=1 Q
. . Q
. E D
. . S ORPLCPTR=$S($L(ORICD):+$$CODECS^ICDEX(ORICD,80,ORDT),1:""),ORPLCSYS=$S($L(ORICD):$$SAB^ICDEX(ORPLCPTR,ORDT),1:"ICD")
. . I '+$$STATCHK^ICDEX(ORICD,ORDT,ORPLCPTR) S ORQUIT=1 Q
. . Q
. I +ORQUIT Q
. S ORPCNT=ORPCNT+1
. ; RETURN:
. ; PROBLEM^DISPLAY TEXT^ICD CODE^ICD CODE IFN^^SNOMED CT CONCEPT CODE^SNOMED CT DESIGNATION CODE
. S @ORTG@(ORPCNT)=$P(ORITEM,U,1)_U_ORTEXT_U_"("_$P($$CODECS^ICDEX($P(ORICD,"/"),80,ORDT),U,2)_" "_$G(ORICD)_")"_U_+$$ICDDX^ICDEX($P(ORICD,"/"),ORDT,ORPLCSYS)_U_U_$P(ORITEM,U,5,6)
Q
;
;------------------ Filter Providers ---------------------
;
GETRPRV(RETURN,INP) ; GET LIST OF RESPONSIBLE PROVIDERS FROM PRBLM LIST
; RETURN - aa list of responsible providers from which to select for filtering
; INP - array of problem list providers to select from
;
N S
S S=""
F I=1:1 S S=$O(INP(S)) Q:S="" D
. I INP(S)'="",$G(^VA(200,INP(S),0))'="" D Q ; get next
.. S RETURN(I)=INP(S)_U_$P(^VA(200,INP(S),0),U)
S RETURN(0)="-1"_U_"<None recorded>" ; return empty provider
Q
;
;------------------- GET FILTERED CLINIC LIST ------------------------
;
GETCLIN(RETURN,INP) ; Get FILTERED LIST OF CLINICS
; RETURN NAMES FOR LIST OF CLINICS PASSED IN
N I,S
S S=""
F I=1:1 S S=$O(INP(S)) Q:S="" D
. I INP(S)'="",$G(^SC(INP(S),0))'="" D Q ; get next
.. S RETURN(I)=INP(S)_U_$P(^SC(INP(S),0),U,1)
;. S RETURN(I)="-1"_U_"None" ; return empty location
Q
;
GETSRVC(RETURN,INP) ; GET FILTERED LIST OF INPATIENT SERVICES
; RETURN NAMES FOR LIST OF IEN PASSED IN
N I,S
S S=""
F I=1:1 S S=$O(INP(S)) Q:S="" D
. I INP(S)'="",$G(^DIC(49,INP(S),0))'="" D Q ; get next
.. S RETURN(I)=INP(S)_U_$P(^DIC(49,INP(S),0),U,1)
;. S RETURN(I)="-1"_U_"None" ; return empty service
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORQQPL3 10577 printed Dec 13, 2024@02:33:42 Page 2
ORQQPL3 ; ALB/PDR,REV,ISL/JER/TC - Problem List RPCs ;02/13/17 14:04
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,148,173,243,280,306,361,385,429**;Dec 17, 1997;Build 33
+2 ;
+3 ; External References:
+4 ; $$ICDDESC^GMPLUTL2 ICR #2741
+5 ; $$PROBTEXT^GMPLX ICR #2742
+6 ; $$CODECS/$$CSI/$$ICDDX/$$SAB/$$STATCHK^ICDEX ICR #5747
+7 ; $$ICDDATA/$$STATCHK^ICDXCODE ICR #5699
+8 ; $$STATCHK^LEXSRC2 ICR #4083
+9 ; $$IMPDATE^LEXU ICR #5679
+10 ; $$DT^XLFDT ICR #10103
+11 ; $$GET^XPAR ICR #2263
+12 ;
+13 ;---------------- LIST PATIENT PROBLEMS ------------------------
+14 ;
PROBL(ROOT,DFN,CONTEXT,ORIDT) ; GET LIST OF PATIENT PROBLEMS
+1 NEW DIWL,DIWR,DIWF
+2 NEW ST,ORI,ORX
+3 SET ORIDT=$GET(ORIDT,DT)
+4 SET (LCNT,NUM)=0
+5 SET DIWL=1
SET DIWR=48
SET DIWF="C48"
+6 SET CONTEXT=";;"_$GET(CONTEXT)
+7 IF CONTEXT=";;"
SET CONTEXT=";;A"
+8 SET ST=$PIECE(CONTEXT,";",3)
+9 ;
+10 ; show deleted only
IF ST="R"
DO DELLIST(.ROOT,+DFN,ORIDT)
+11 ; show others - don't trust ELSE here
IF ST'="R"
DO LIST(.ROOT,+DFN,ST,ORIDT)
+12 ;
+13 IF ROOT(0)<1
Begin DoDot:1
+14 SET LCNT=1
+15 SET ROOT(1)=" "_$$PAD^ORCHTAB("No data available.",49)_"|"
End DoDot:1
+16 QUIT
+17 ;
+18 ;
LIST(GMPL,GMPDFN,GMPSTAT,ORIDT) ; -- Returns list of problems for patient GMPDFN
+1 ; in GMPL(#)=ifn^status^description^ICD^onset^last modified^SC^SpExp^Condition^Loc^
+2 ; loc.type^prov^service^priority^has comment^date recorded^SC condition(s)^
+3 ; inactive flag^ICD long description^ICD coding system
+4 ; & GMPL(0)=number of problems returned
+5 ; This is virtually same as LIST^GMPLUTL2 except that it appends the
+6 ; condition - T)ranscribed or P)ermanent,location,loc type,provider, service.
+7 ;
+8 NEW CNT,SP,NUM,ORLIST,ORVIEW,GMPARAM,IMPLDT
+9 if $GET(GMPDFN)'>0
QUIT
+10 SET IMPLDT=$$IMPDATE^LEXU("10D")
+11 SET ORIDT=$GET(ORIDT,DT)
+12 if ORIDT=0
SET ORIDT=DT
+13 SET CNT=0
SET SP=""
+14 SET GMPARAM("QUIET")=1
+15 SET GMPARAM("REV")=$PIECE($GET(^GMPL(125.99,1,0)),U,5)="R"
+16 SET ORVIEW("ACT")=GMPSTAT
+17 SET ORVIEW("PROV")=0
+18 SET ORVIEW("VIEW")=""
+19 ;
+20 DO GETPLIST^GMPLMGR1(.ORLIST,.ORTOTAL,.ORVIEW)
+21 ;
+22 FOR NUM=0:0
SET NUM=$ORDER(ORLIST(NUM))
if NUM'>0
QUIT
Begin DoDot:1
+23 NEW GMPL0,GMPL1,GMPL800,GMPL802,I,IFN,SCT,ST,ONSET,ICD,LASTMOD,PRIO,DTREC,ICDD,ORDTINT,ORPLCSYS
+24 NEW SC,ORTOTAL,LIN,LOC,LT,PROV,SERV,HASCMT,SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,INACT
+25 SET IFN=+ORLIST(NUM)
if IFN'>0
QUIT
+26 SET (ICDD,INACT)=""
+27 SET GMPL0=$GET(^AUPNPROB(IFN,0))
+28 SET GMPL1=$GET(^AUPNPROB(IFN,1))
+29 SET GMPL800=$GET(^AUPNPROB(IFN,800))
SET SCT=$PIECE(GMPL800,U)
+30 SET GMPL802=$GET(^AUPNPROB(IFN,802))
+31 SET HASCMT=($DATA(^AUPNPROB(IFN,11,0))>0)
+32 SET CNT=CNT+1
+33 NEW LEX
+34 SET ORDTINT=$SELECT(+$PIECE(GMPL802,U,1):$PIECE(GMPL802,U,1),1:$PIECE(GMPL0,U,8))
+35 SET ORPLCSYS=$SELECT($PIECE(GMPL802,U,2)]"":$PIECE(GMPL802,U,2),1:$$SAB^ICDEX($$CSI^ICDEX(80,+GMPL0),ORDTINT))
+36 SET ICD=$PIECE($$ICDDATA^ICDXCODE(ORPLCSYS,+GMPL0,ORDTINT,"I"),U,2)
+37 IF (ORIDT<IMPLDT)
IF (+$$STATCHK^ICDXCODE($$CSI^ICDEX(80,+GMPL0),ICD,ORIDT)'=1)
SET INACT="#"
+38 IF +$GET(SCT)
IF (+$$STATCHK^LEXSRC2(SCT,ORIDT,.LEX)'=1)
SET INACT="$"
+39 IF $DATA(^AUPNPROB(IFN,803))
Begin DoDot:2
+40 NEW I
SET I=0
+41 FOR
SET I=$ORDER(^AUPNPROB(IFN,803,I))
if +I'>0
QUIT
SET $PIECE(ICD,"/",(I+1))=$PIECE($GET(^AUPNPROB(IFN,803,I,0)),U)
End DoDot:2
+42 IF +SCT'>0
IF (+ICD>0)
SET ICDD=$$ICDDESC^GMPLUTL2(ICD,ORIDT,ORPLCSYS)
+43 SET LASTMOD=$PIECE(GMPL0,U,3)
+44 SET ST=$PIECE(GMPL0,U,12)
+45 SET ONSET=$PIECE(GMPL0,U,13)
+46 SET SC=$SELECT(+$PIECE(GMPL1,U,10):"SC",$PIECE(GMPL1,U,10)=0:"NSC",1:"")
+47 SET AO=$SELECT(+$PIECE(GMPL1,U,11):"/AO",1:"")
+48 SET IR=$SELECT(+$PIECE(GMPL1,U,12):"/IR",1:"")
+49 SET ENV=$SELECT(+$PIECE(GMPL1,U,13):"/EC",1:"")
+50 SET HNC=$SELECT(+$PIECE(GMPL1,U,15):"/HNC",1:"")
+51 SET MST=$SELECT(+$PIECE(GMPL1,U,16):"/MST",1:"")
+52 SET CV=$SELECT(+$PIECE(GMPL1,U,17):"/CV",1:"")
+53 SET SHD=$SELECT(+$PIECE(GMPL1,U,18):"/SHD",1:"")
+54 SET SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD
+55 SET LOC=$PIECE(GMPL1,U,8)
+56 SET DTREC=$PIECE(GMPL1,U,9)
+57 SET LT=""
+58 IF LOC'=""
SET LT=$PIECE($GET(^SC(LOC,0)),"^",3)
SET LOC=LOC_";"_$PIECE($GET(^SC(LOC,0)),U,1)
+59 ; responsible provider
SET PROV=$PIECE(GMPL1,U,5)
+60 IF PROV'=""
SET PROV=PROV_";"_$PIECE($GET(^VA(200,PROV,0)),U,1)
+61 SET SERV=$PIECE(GMPL1,U,6)
+62 ; not sure how it gets set to 0, but need consistency in GUI
IF SERV=0
SET SERV=""
+63 IF SERV'=""
SET SERV=SERV_";"_$PIECE($GET(^DIC(49,SERV,0)),U,1)
+64 SET SP=""
+65 FOR I=11,12,13
if $PIECE(GMPL1,U,I)
SET SP=SP_$SELECT(I=11:"A",I=12:"I",1:"P")
+66 SET PRIO=$PIECE(GMPL1,U,14)
+67 SET LIN=IFN_U_ST_U_$$PROBTEXT^GMPLX(IFN)_U_ICD_U_ONSET
+68 SET LIN=LIN_U_LASTMOD_U_SC_U_SP_U_$PIECE(GMPL1,U,2)
+69 SET LIN=LIN_U_LOC_U_LT_U_PROV_U_SERV_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT_U_ICDD_U_ORPLCSYS
+70 SET GMPL(CNT)=LIN
End DoDot:1
+71 SET GMPL(0)=CNT
+72 QUIT
+73 ;
+74 ;
+75 ;------------------------ GET LIST OF DELETED PROBLEMS -----------------------------
+76 ;
DELLIST(RETURN,GMPDFN,ORIDT) ; GET LIST OF DELETED PROBLEMS
+1 ; see GETPLIST^GMPLMGR1 and LIST^GMPUTL2
+2 NEW S,I,IMPLDT
+3 SET IMPLDT=$$IMPDATE^LEXU("10D")
+4 SET ORIDT=$GET(ORIDT,DT)
+5 if ORIDT=0
SET ORIDT=DT
+6 SET I=0
SET S=""
+7 FOR
SET S=$ORDER(^AUPNPROB("ACTIVE",GMPDFN,S))
if S=""
QUIT
Begin DoDot:1
+8 NEW IFN,L0,L1,L800,L802,SCT,ST,TXT,ICD,ONSET,MOD,SC,SP,LOC,LT,PROV,SERV,PRIO,HASCMT,DTREC
+9 NEW SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,INACT,ORPLCSYS,ICDD,ORDTINT
+10 SET IFN=""
+11 FOR
SET IFN=$ORDER(^AUPNPROB("ACTIVE",+GMPDFN,S,IFN))
if IFN=""
QUIT
Begin DoDot:2
+12 IF $PIECE($GET(^AUPNPROB(IFN,1)),U,2)="H"
Begin DoDot:3
+13 SET L0=$GET(^AUPNPROB(IFN,0))
+14 SET L800=$GET(^AUPNPROB(IFN,800))
SET SCT=$PIECE(L800,U)
+15 SET L802=$GET(^AUPNPROB(IFN,802))
+16 if L0=""
QUIT
+17 SET (ICDD,INACT)=""
+18 SET L1=$GET(^AUPNPROB(IFN,1))
+19 SET ST=$PIECE(L0,U,12)
+20 SET TXT=$$PROBTEXT^GMPLX(IFN)
+21 SET ORDTINT=$SELECT(+$PIECE(L802,U,1):$PIECE(L802,U,1),1:$PIECE(L0,U,8))
+22 SET ORPLCSYS=$SELECT($PIECE(L802,U,2)]"":$PIECE(L802,U,2),1:$$SAB^ICDEX($$CSI^ICDEX(80,+L0),ORDTINT))
+23 SET ICD=$PIECE($$ICDDATA^ICDXCODE(ORPLCSYS,+L0,ORDTINT,"I"),U,2)
+24 IF (ORIDT<IMPLDT)
IF (+$$STATCHK^ICDXCODE($$CSI^ICDEX(80,+L0),ICD,ORIDT)'=1)
SET INACT="#"
+25 IF +SCT'>0
IF (+ICD>0)
SET ICDD=$$ICDDESC^GMPLUTL2(ICD,ORIDT,ORPLCSYS)
+26 SET ONSET=$PIECE(L0,U,13)
+27 SET MOD=$PIECE(L0,U,3)
+28 SET SC=$SELECT(+$PIECE(L1,U,10):"SC",$PIECE(L1,U,10)=0:"NSC",1:"")
+29 SET AO=$SELECT(+$PIECE(L1,U,11):"/AO",1:"")
+30 SET IR=$SELECT(+$PIECE(L1,U,12):"/IR",1:"")
+31 SET ENV=$SELECT(+$PIECE(L1,U,13):"/EC",1:"")
+32 SET HNC=$SELECT(+$PIECE(L1,U,15):"/HNC",1:"")
+33 SET MST=$SELECT(+$PIECE(L1,U,16):"/MST",1:"")
+34 SET CV=$SELECT(+$PIECE(L1,U,17):"/CV",1:"")
+35 SET SHD=$SELECT(+$PIECE(L1,U,18):"/SHD",1:"")
+36 SET SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD
+37 SET SP=$$GETSP
+38 SET LOC=$PIECE(L1,U,8)
+39 SET LT=""
+40 IF LOC'=""
SET LT=$PIECE($GET(^SC(LOC,0)),"^",3)
+41 ; responsible provider
SET PROV=$PIECE(L1,U,5)
+42 SET SERV=$PIECE(L1,U,6)
+43 SET PRIO=$PIECE(L1,U,14)
+44 SET HASCMT=($DATA(^AUPNPROB(IFN,11,0))>0)
+45 SET DTREC=$PIECE(L1,U,9)
+46 SET I=I+1
+47 SET RETURN(I)=IFN_U_ST_U_TXT_U_ICD_U_ONSET
+48 SET RETURN(I)=RETURN(I)_U_MOD_U_SC_U_SP_U_$PIECE(L1,U,2)
+49 SET RETURN(I)=RETURN(I)_U_LOC_U_LT_U_PROV_U_SERV
+50 SET RETURN(I)=RETURN(I)_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT_U_ICDD_U_ORPLCSYS
End DoDot:3
End DoDot:2
End DoDot:1
+51 SET RETURN(0)=I
+52 QUIT
+53 ;
GETSP() ; GET EXPOSURES
+1 NEW I
+2 SET SP=""
+3 FOR I=11,12,13
if $PIECE(L1,U,I)
SET SP=SP_$SELECT(I=11:"A",I=12:"I",1:"P")
+4 QUIT SP
+5 ;
+6 ; adapted from ^GMPLBLD3 ;9/96
+7 ;
+8 ; ----------------------- GET USER PROBLEM CATEGORIES --------------
+9 ;
CAT(ORTMP,ORDUZ,ORCLIN) ; Get user category list
+1 NEW ORGSEQ,ORGCNT,ORGROUP,ORHDR,ORIFN,ORLCNT,ORITEM,ORTG,ORSLST
+2 ; put list in local
SET ORTG=$NAME(ORTMP)
+3 KILL @ORTG
+4 SET (ORGSEQ,ORGCNT,ORLCNT)=0
+5 ;
+6 ; get approp default list
SET ORSLST=$$GET^XPAR("USR^LOC.`"_ORCLIN_"^DIV^SYS^PKG","ORQQPL SELECTION LIST",1)
+7 ; Build multiple of category\problems
+8 ; Iterate categories
+9 FOR
SET ORGSEQ=$ORDER(^GMPL(125,"AD",+ORSLST,ORGSEQ))
if ORGSEQ'>0
QUIT
Begin DoDot:1
+10 SET ORIFN=$ORDER(^GMPL(125,"AD",+ORSLST,ORGSEQ,0))
if ORIFN'>0
QUIT
+11 SET ORITEM=$GET(^GMPL(125,+ORSLST,1,ORIFN,0))
+12 SET ORGROUP=+$PIECE(ORITEM,U,1)
+13 SET ORHDR=ORGROUP_U_$PIECE(ORITEM,U,3,4)
+14 SET ORGCNT=ORGCNT+1
+15 ; put category into temp global
SET @ORTG@(ORGCNT)=ORHDR
End DoDot:1
+16 QUIT
+17 ;
+18 ;----------------------- USER PROBLEM LIST --------------------------
+19 ;
PROB(TMP,ORGROUP) ; Get user problem list for given group
+1 NEW ORPSEQ,ORPCNT,ORIFN,ORITEM,ORTG,ORICD,ORTEXT,ORPLCSYS,ORPLCPTR,ORDT,ORSCTC,ORLCNT
+2 ; put list in local
SET ORTG=$NAME(TMP)
+3 KILL @ORTG
+4 SET ORLCNT=0
+5 ;
+6 ; iterate through problems in category
+7 SET (ORPSEQ,ORPCNT)=0
SET ORDT=$$DT^XLFDT
+8 FOR
SET ORPSEQ=$ORDER(^GMPL(125.11,"C",ORGROUP,ORPSEQ))
if ORPSEQ'>0
QUIT
Begin DoDot:1
+9 NEW ORI,ORK,ORQUIT
SET ORQUIT=0
+10 SET ORIFN=$ORDER(^GMPL(125.11,"C",ORGROUP,ORPSEQ,0))
if ORIFN'>0
QUIT
+11 SET ORITEM=$GET(^GMPL(125.11,ORGROUP,1,ORIFN,0))
+12 SET ORTEXT=$PIECE(ORITEM,U,3)
SET ORICD=$PIECE(ORITEM,U,4)
+13 SET ORSCTC=$PIECE(ORITEM,U,5)
+14 ; exclude any problems w/inactive SNOMED codes
+15 IF $LENGTH(ORSCTC)
Begin DoDot:2
+16 IF '$$STATCHK^LEXSRC2(ORSCTC,ORDT,"","SCT")
SET ORQUIT=1
QUIT
End DoDot:2
+17 ; if any ICD codes inactive, exclude from list
+18 IF $LENGTH(ORICD)&(ORICD["/")
Begin DoDot:2
+19 FOR ORK=1:1:$LENGTH(ORICD,"/")
if +ORQUIT
QUIT
Begin DoDot:3
+20 SET ORPLCPTR=+$$CODECS^ICDEX($PIECE(ORICD,"/",ORK),80,ORDT)
SET ORPLCSYS=$$SAB^ICDEX(ORPLCPTR,ORDT)
+21 IF '+$$STATCHK^ICDEX($PIECE(ORICD,"/",ORK),ORDT,ORPLCPTR)
SET ORQUIT=1
QUIT
End DoDot:3
+22 QUIT
End DoDot:2
+23 IF '$TEST
Begin DoDot:2
+24 SET ORPLCPTR=$SELECT($LENGTH(ORICD):+$$CODECS^ICDEX(ORICD,80,ORDT),1:"")
SET ORPLCSYS=$SELECT($LENGTH(ORICD):$$SAB^ICDEX(ORPLCPTR,ORDT),1:"ICD")
+25 IF '+$$STATCHK^ICDEX(ORICD,ORDT,ORPLCPTR)
SET ORQUIT=1
QUIT
+26 QUIT
End DoDot:2
+27 IF +ORQUIT
QUIT
+28 SET ORPCNT=ORPCNT+1
+29 ; RETURN:
+30 ; PROBLEM^DISPLAY TEXT^ICD CODE^ICD CODE IFN^^SNOMED CT CONCEPT CODE^SNOMED CT DESIGNATION CODE
+31 SET @ORTG@(ORPCNT)=$PIECE(ORITEM,U,1)_U_ORTEXT_U_"("_$PIECE($$CODECS^ICDEX($PIECE(ORICD,"/"),80,ORDT),U,2)_" "_$GET(ORICD)_")"_U_+$$ICDDX^ICDEX($PIECE(ORICD,"/"),ORDT,ORPLCSYS)_U_U_$PIECE(ORITEM,U,5,6)
End DoDot:1
+32 QUIT
+33 ;
+34 ;------------------ Filter Providers ---------------------
+35 ;
GETRPRV(RETURN,INP) ; GET LIST OF RESPONSIBLE PROVIDERS FROM PRBLM LIST
+1 ; RETURN - aa list of responsible providers from which to select for filtering
+2 ; INP - array of problem list providers to select from
+3 ;
+4 NEW S
+5 SET S=""
+6 FOR I=1:1
SET S=$ORDER(INP(S))
if S=""
QUIT
Begin DoDot:1
+7 ; get next
IF INP(S)'=""
IF $GET(^VA(200,INP(S),0))'=""
Begin DoDot:2
+8 SET RETURN(I)=INP(S)_U_$PIECE(^VA(200,INP(S),0),U)
End DoDot:2
QUIT
End DoDot:1
+9 ; return empty provider
SET RETURN(0)="-1"_U_"<None recorded>"
+10 QUIT
+11 ;
+12 ;------------------- GET FILTERED CLINIC LIST ------------------------
+13 ;
GETCLIN(RETURN,INP) ; Get FILTERED LIST OF CLINICS
+1 ; RETURN NAMES FOR LIST OF CLINICS PASSED IN
+2 NEW I,S
+3 SET S=""
+4 FOR I=1:1
SET S=$ORDER(INP(S))
if S=""
QUIT
Begin DoDot:1
+5 ; get next
IF INP(S)'=""
IF $GET(^SC(INP(S),0))'=""
Begin DoDot:2
+6 SET RETURN(I)=INP(S)_U_$PIECE(^SC(INP(S),0),U,1)
End DoDot:2
QUIT
End DoDot:1
+7 ;. S RETURN(I)="-1"_U_"None" ; return empty location
+8 QUIT
+9 ;
GETSRVC(RETURN,INP) ; GET FILTERED LIST OF INPATIENT SERVICES
+1 ; RETURN NAMES FOR LIST OF IEN PASSED IN
+2 NEW I,S
+3 SET S=""
+4 FOR I=1:1
SET S=$ORDER(INP(S))
if S=""
QUIT
Begin DoDot:1
+5 ; get next
IF INP(S)'=""
IF $GET(^DIC(49,INP(S),0))'=""
Begin DoDot:2
+6 SET RETURN(I)=INP(S)_U_$PIECE(^DIC(49,INP(S),0),U,1)
End DoDot:2
QUIT
End DoDot:1
+7 ;. S RETURN(I)="-1"_U_"None" ; return empty service
+8 QUIT
