- 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 Jan 18, 2025@03:34:51 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