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

ORQQPL3.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; External References:
  1. ; $$ICDDESC^GMPLUTL2 ICR #2741
  1. ; $$PROBTEXT^GMPLX ICR #2742
  1. ; $$CODECS/$$CSI/$$ICDDX/$$SAB/$$STATCHK^ICDEX ICR #5747
  1. ; $$ICDDATA/$$STATCHK^ICDXCODE ICR #5699
  1. ; $$STATCHK^LEXSRC2 ICR #4083
  1. ; $$IMPDATE^LEXU ICR #5679
  1. ; $$DT^XLFDT ICR #10103
  1. ; $$GET^XPAR ICR #2263
  1. ;
  1. ;---------------- LIST PATIENT PROBLEMS ------------------------
  1. ;
  1. PROBL(ROOT,DFN,CONTEXT,ORIDT) ; GET LIST OF PATIENT PROBLEMS
  1. N DIWL,DIWR,DIWF
  1. N ST,ORI,ORX
  1. S ORIDT=$G(ORIDT,DT)
  1. S (LCNT,NUM)=0
  1. S DIWL=1,DIWR=48,DIWF="C48"
  1. S CONTEXT=";;"_$G(CONTEXT)
  1. I CONTEXT=";;" S CONTEXT=";;A"
  1. S ST=$P(CONTEXT,";",3)
  1. ;
  1. I ST="R" D DELLIST(.ROOT,+DFN,ORIDT) ; show deleted only
  1. I ST'="R" D LIST(.ROOT,+DFN,ST,ORIDT) ; show others - don't trust ELSE here
  1. ;
  1. I ROOT(0)<1 D
  1. . S LCNT=1
  1. . S ROOT(1)=" "_$$PAD^ORCHTAB("No data available.",49)_"|"
  1. Q
  1. ;
  1. ;
  1. 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^
  1. ; loc.type^prov^service^priority^has comment^date recorded^SC condition(s)^
  1. ; inactive flag^ICD long description^ICD coding system
  1. ; & GMPL(0)=number of problems returned
  1. ; This is virtually same as LIST^GMPLUTL2 except that it appends the
  1. ; condition - T)ranscribed or P)ermanent,location,loc type,provider, service.
  1. ;
  1. N CNT,SP,NUM,ORLIST,ORVIEW,GMPARAM,IMPLDT
  1. Q:$G(GMPDFN)'>0
  1. S IMPLDT=$$IMPDATE^LEXU("10D")
  1. S ORIDT=$G(ORIDT,DT)
  1. S:ORIDT=0 ORIDT=DT
  1. S CNT=0,SP=""
  1. S GMPARAM("QUIET")=1
  1. S GMPARAM("REV")=$P($G(^GMPL(125.99,1,0)),U,5)="R"
  1. S ORVIEW("ACT")=GMPSTAT
  1. S ORVIEW("PROV")=0
  1. S ORVIEW("VIEW")=""
  1. ;
  1. D GETPLIST^GMPLMGR1(.ORLIST,.ORTOTAL,.ORVIEW)
  1. ;
  1. F NUM=0:0 S NUM=$O(ORLIST(NUM)) Q:NUM'>0 D
  1. . N GMPL0,GMPL1,GMPL800,GMPL802,I,IFN,SCT,ST,ONSET,ICD,LASTMOD,PRIO,DTREC,ICDD,ORDTINT,ORPLCSYS
  1. . N SC,ORTOTAL,LIN,LOC,LT,PROV,SERV,HASCMT,SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,INACT
  1. . S IFN=+ORLIST(NUM) Q:IFN'>0
  1. . S (ICDD,INACT)=""
  1. . S GMPL0=$G(^AUPNPROB(IFN,0))
  1. . S GMPL1=$G(^AUPNPROB(IFN,1))
  1. . S GMPL800=$G(^AUPNPROB(IFN,800)),SCT=$P(GMPL800,U)
  1. . S GMPL802=$G(^AUPNPROB(IFN,802))
  1. . S HASCMT=($D(^AUPNPROB(IFN,11,0))>0)
  1. . S CNT=CNT+1
  1. . N LEX
  1. . S ORDTINT=$S(+$P(GMPL802,U,1):$P(GMPL802,U,1),1:$P(GMPL0,U,8))
  1. . S ORPLCSYS=$S($P(GMPL802,U,2)]"":$P(GMPL802,U,2),1:$$SAB^ICDEX($$CSI^ICDEX(80,+GMPL0),ORDTINT))
  1. . S ICD=$P($$ICDDATA^ICDXCODE(ORPLCSYS,+GMPL0,ORDTINT,"I"),U,2)
  1. . I (ORIDT<IMPLDT),(+$$STATCHK^ICDXCODE($$CSI^ICDEX(80,+GMPL0),ICD,ORIDT)'=1) S INACT="#"
  1. . I +$G(SCT),(+$$STATCHK^LEXSRC2(SCT,ORIDT,.LEX)'=1) S INACT="$"
  1. . I $D(^AUPNPROB(IFN,803)) D
  1. . . N I S I=0
  1. . . F S I=$O(^AUPNPROB(IFN,803,I)) Q:+I'>0 S $P(ICD,"/",(I+1))=$P($G(^AUPNPROB(IFN,803,I,0)),U)
  1. . I +SCT'>0,(+ICD>0) S ICDD=$$ICDDESC^GMPLUTL2(ICD,ORIDT,ORPLCSYS)
  1. . S LASTMOD=$P(GMPL0,U,3)
  1. . S ST=$P(GMPL0,U,12)
  1. . S ONSET=$P(GMPL0,U,13)
  1. . S SC=$S(+$P(GMPL1,U,10):"SC",$P(GMPL1,U,10)=0:"NSC",1:"")
  1. . S AO=$S(+$P(GMPL1,U,11):"/AO",1:"")
  1. . S IR=$S(+$P(GMPL1,U,12):"/IR",1:"")
  1. . S ENV=$S(+$P(GMPL1,U,13):"/EC",1:"")
  1. . S HNC=$S(+$P(GMPL1,U,15):"/HNC",1:"")
  1. . S MST=$S(+$P(GMPL1,U,16):"/MST",1:"")
  1. . S CV=$S(+$P(GMPL1,U,17):"/CV",1:"")
  1. . S SHD=$S(+$P(GMPL1,U,18):"/SHD",1:"")
  1. . S SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD
  1. . S LOC=$P(GMPL1,U,8)
  1. . S DTREC=$P(GMPL1,U,9)
  1. . S LT=""
  1. . I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3),LOC=LOC_";"_$P($G(^SC(LOC,0)),U,1)
  1. . S PROV=$P(GMPL1,U,5) ; responsible provider
  1. . I PROV'="" S PROV=PROV_";"_$P($G(^VA(200,PROV,0)),U,1)
  1. . S SERV=$P(GMPL1,U,6)
  1. . I SERV=0 S SERV="" ; not sure how it gets set to 0, but need consistency in GUI
  1. . I SERV'="" S SERV=SERV_";"_$P($G(^DIC(49,SERV,0)),U,1)
  1. . S SP=""
  1. . F I=11,12,13 S:$P(GMPL1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P")
  1. . S PRIO=$P(GMPL1,U,14)
  1. . S LIN=IFN_U_ST_U_$$PROBTEXT^GMPLX(IFN)_U_ICD_U_ONSET
  1. . S LIN=LIN_U_LASTMOD_U_SC_U_SP_U_$P(GMPL1,U,2)
  1. . 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
  1. . S GMPL(CNT)=LIN
  1. S GMPL(0)=CNT
  1. Q
  1. ;
  1. ;
  1. ;------------------------ GET LIST OF DELETED PROBLEMS -----------------------------
  1. ;
  1. DELLIST(RETURN,GMPDFN,ORIDT) ; GET LIST OF DELETED PROBLEMS
  1. ; see GETPLIST^GMPLMGR1 and LIST^GMPUTL2
  1. N S,I,IMPLDT
  1. S IMPLDT=$$IMPDATE^LEXU("10D")
  1. S ORIDT=$G(ORIDT,DT)
  1. S:ORIDT=0 ORIDT=DT
  1. S I=0,S=""
  1. F S S=$O(^AUPNPROB("ACTIVE",GMPDFN,S)) Q:S="" D
  1. . N IFN,L0,L1,L800,L802,SCT,ST,TXT,ICD,ONSET,MOD,SC,SP,LOC,LT,PROV,SERV,PRIO,HASCMT,DTREC
  1. . N SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,INACT,ORPLCSYS,ICDD,ORDTINT
  1. . S IFN=""
  1. . F S IFN=$O(^AUPNPROB("ACTIVE",+GMPDFN,S,IFN)) Q:IFN="" D
  1. .. I $P($G(^AUPNPROB(IFN,1)),U,2)="H" D
  1. ... S L0=$G(^AUPNPROB(IFN,0))
  1. ... S L800=$G(^AUPNPROB(IFN,800)),SCT=$P(L800,U)
  1. ... S L802=$G(^AUPNPROB(IFN,802))
  1. ... Q:L0=""
  1. ... S (ICDD,INACT)=""
  1. ... S L1=$G(^AUPNPROB(IFN,1))
  1. ... S ST=$P(L0,U,12)
  1. ... S TXT=$$PROBTEXT^GMPLX(IFN)
  1. ... S ORDTINT=$S(+$P(L802,U,1):$P(L802,U,1),1:$P(L0,U,8))
  1. ... S ORPLCSYS=$S($P(L802,U,2)]"":$P(L802,U,2),1:$$SAB^ICDEX($$CSI^ICDEX(80,+L0),ORDTINT))
  1. ... S ICD=$P($$ICDDATA^ICDXCODE(ORPLCSYS,+L0,ORDTINT,"I"),U,2)
  1. ... I (ORIDT<IMPLDT),(+$$STATCHK^ICDXCODE($$CSI^ICDEX(80,+L0),ICD,ORIDT)'=1) S INACT="#"
  1. ... I +SCT'>0,(+ICD>0) S ICDD=$$ICDDESC^GMPLUTL2(ICD,ORIDT,ORPLCSYS)
  1. ... S ONSET=$P(L0,U,13)
  1. ... S MOD=$P(L0,U,3)
  1. ... S SC=$S(+$P(L1,U,10):"SC",$P(L1,U,10)=0:"NSC",1:"")
  1. ... S AO=$S(+$P(L1,U,11):"/AO",1:"")
  1. ... S IR=$S(+$P(L1,U,12):"/IR",1:"")
  1. ... S ENV=$S(+$P(L1,U,13):"/EC",1:"")
  1. ... S HNC=$S(+$P(L1,U,15):"/HNC",1:"")
  1. ... S MST=$S(+$P(L1,U,16):"/MST",1:"")
  1. ... S CV=$S(+$P(L1,U,17):"/CV",1:"")
  1. ... S SHD=$S(+$P(L1,U,18):"/SHD",1:"")
  1. ... S SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD
  1. ... S SP=$$GETSP
  1. ... S LOC=$P(L1,U,8)
  1. ... S LT=""
  1. ... I LOC'="" S LT=$P($G(^SC(LOC,0)),"^",3)
  1. ... S PROV=$P(L1,U,5) ; responsible provider
  1. ... S SERV=$P(L1,U,6)
  1. ... S PRIO=$P(L1,U,14)
  1. ... S HASCMT=($D(^AUPNPROB(IFN,11,0))>0)
  1. ... S DTREC=$P(L1,U,9)
  1. ... S I=I+1
  1. ... S RETURN(I)=IFN_U_ST_U_TXT_U_ICD_U_ONSET
  1. ... S RETURN(I)=RETURN(I)_U_MOD_U_SC_U_SP_U_$P(L1,U,2)
  1. ... S RETURN(I)=RETURN(I)_U_LOC_U_LT_U_PROV_U_SERV
  1. ... S RETURN(I)=RETURN(I)_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT_U_ICDD_U_ORPLCSYS
  1. S RETURN(0)=I
  1. Q
  1. ;
  1. GETSP() ; GET EXPOSURES
  1. N I
  1. S SP=""
  1. F I=11,12,13 S:$P(L1,U,I) SP=SP_$S(I=11:"A",I=12:"I",1:"P")
  1. Q SP
  1. ;
  1. ; adapted from ^GMPLBLD3 ;9/96
  1. ;
  1. ; ----------------------- GET USER PROBLEM CATEGORIES --------------
  1. ;
  1. CAT(ORTMP,ORDUZ,ORCLIN) ; Get user category list
  1. N ORGSEQ,ORGCNT,ORGROUP,ORHDR,ORIFN,ORLCNT,ORITEM,ORTG,ORSLST
  1. S ORTG=$NAME(ORTMP) ; put list in local
  1. K @ORTG
  1. S (ORGSEQ,ORGCNT,ORLCNT)=0
  1. ;
  1. S ORSLST=$$GET^XPAR("USR^LOC.`"_ORCLIN_"^DIV^SYS^PKG","ORQQPL SELECTION LIST",1) ; get approp default list
  1. ; Build multiple of category\problems
  1. ; Iterate categories
  1. F S ORGSEQ=$O(^GMPL(125,"AD",+ORSLST,ORGSEQ)) Q:ORGSEQ'>0 D
  1. . S ORIFN=$O(^GMPL(125,"AD",+ORSLST,ORGSEQ,0)) Q:ORIFN'>0
  1. . S ORITEM=$G(^GMPL(125,+ORSLST,1,ORIFN,0))
  1. . S ORGROUP=+$P(ORITEM,U,1)
  1. . S ORHDR=ORGROUP_U_$P(ORITEM,U,3,4)
  1. . S ORGCNT=ORGCNT+1
  1. . S @ORTG@(ORGCNT)=ORHDR ; put category into temp global
  1. Q
  1. ;
  1. ;----------------------- USER PROBLEM LIST --------------------------
  1. ;
  1. PROB(TMP,ORGROUP) ; Get user problem list for given group
  1. N ORPSEQ,ORPCNT,ORIFN,ORITEM,ORTG,ORICD,ORTEXT,ORPLCSYS,ORPLCPTR,ORDT,ORSCTC,ORLCNT
  1. S ORTG=$NAME(TMP) ; put list in local
  1. K @ORTG
  1. S ORLCNT=0
  1. ;
  1. ; iterate through problems in category
  1. S (ORPSEQ,ORPCNT)=0,ORDT=$$DT^XLFDT
  1. F S ORPSEQ=$O(^GMPL(125.11,"C",ORGROUP,ORPSEQ)) Q:ORPSEQ'>0 D
  1. . N ORI,ORK,ORQUIT S ORQUIT=0
  1. . S ORIFN=$O(^GMPL(125.11,"C",ORGROUP,ORPSEQ,0)) Q:ORIFN'>0
  1. . S ORITEM=$G(^GMPL(125.11,ORGROUP,1,ORIFN,0))
  1. . S ORTEXT=$P(ORITEM,U,3),ORICD=$P(ORITEM,U,4)
  1. . S ORSCTC=$P(ORITEM,U,5)
  1. . ; exclude any problems w/inactive SNOMED codes
  1. . I $L(ORSCTC) D
  1. . . I '$$STATCHK^LEXSRC2(ORSCTC,ORDT,"","SCT") S ORQUIT=1 Q
  1. . ; if any ICD codes inactive, exclude from list
  1. . I $L(ORICD)&(ORICD["/") D
  1. . . F ORK=1:1:$L(ORICD,"/") Q:+ORQUIT D
  1. . . . S ORPLCPTR=+$$CODECS^ICDEX($P(ORICD,"/",ORK),80,ORDT),ORPLCSYS=$$SAB^ICDEX(ORPLCPTR,ORDT)
  1. . . . I '+$$STATCHK^ICDEX($P(ORICD,"/",ORK),ORDT,ORPLCPTR) S ORQUIT=1 Q
  1. . . Q
  1. . E D
  1. . . S ORPLCPTR=$S($L(ORICD):+$$CODECS^ICDEX(ORICD,80,ORDT),1:""),ORPLCSYS=$S($L(ORICD):$$SAB^ICDEX(ORPLCPTR,ORDT),1:"ICD")
  1. . . I '+$$STATCHK^ICDEX(ORICD,ORDT,ORPLCPTR) S ORQUIT=1 Q
  1. . . Q
  1. . I +ORQUIT Q
  1. . S ORPCNT=ORPCNT+1
  1. . ; RETURN:
  1. . ; PROBLEM^DISPLAY TEXT^ICD CODE^ICD CODE IFN^^SNOMED CT CONCEPT CODE^SNOMED CT DESIGNATION CODE
  1. . 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)
  1. Q
  1. ;
  1. ;------------------ Filter Providers ---------------------
  1. ;
  1. GETRPRV(RETURN,INP) ; GET LIST OF RESPONSIBLE PROVIDERS FROM PRBLM LIST
  1. ; RETURN - aa list of responsible providers from which to select for filtering
  1. ; INP - array of problem list providers to select from
  1. ;
  1. N S
  1. S S=""
  1. F I=1:1 S S=$O(INP(S)) Q:S="" D
  1. . I INP(S)'="",$G(^VA(200,INP(S),0))'="" D Q ; get next
  1. .. S RETURN(I)=INP(S)_U_$P(^VA(200,INP(S),0),U)
  1. S RETURN(0)="-1"_U_"<None recorded>" ; return empty provider
  1. Q
  1. ;
  1. ;------------------- GET FILTERED CLINIC LIST ------------------------
  1. ;
  1. GETCLIN(RETURN,INP) ; Get FILTERED LIST OF CLINICS
  1. ; RETURN NAMES FOR LIST OF CLINICS PASSED IN
  1. N I,S
  1. S S=""
  1. F I=1:1 S S=$O(INP(S)) Q:S="" D
  1. . I INP(S)'="",$G(^SC(INP(S),0))'="" D Q ; get next
  1. .. S RETURN(I)=INP(S)_U_$P(^SC(INP(S),0),U,1)
  1. ;. S RETURN(I)="-1"_U_"None" ; return empty location
  1. Q
  1. ;
  1. GETSRVC(RETURN,INP) ; GET FILTERED LIST OF INPATIENT SERVICES
  1. ; RETURN NAMES FOR LIST OF IEN PASSED IN
  1. N I,S
  1. S S=""
  1. F I=1:1 S S=$O(INP(S)) Q:S="" D
  1. . I INP(S)'="",$G(^DIC(49,INP(S),0))'="" D Q ; get next
  1. .. S RETURN(I)=INP(S)_U_$P(^DIC(49,INP(S),0),U,1)
  1. ;. S RETURN(I)="-1"_U_"None" ; return empty service
  1. Q