ORQQPL3 ; ALB/PDR/REV ; Problem List RPC's ; 8-OCT-1998 09:08:49.29
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,148,173,243**;Dec 17, 1997;Build 242
;
;---------------- LIST PATIENT PROBLEMS ------------------------
;
PROBL(ROOT,DFN,CONTEXT) ; GET LIST OF PATIENT PROBLEMS
N DIWL,DIWR,DIWF
N ST,ORI,ORX
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) ; show deleted only
I ST'="R" D LIST(.ROOT,+DFN,ST) ; 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) ; -- Returns list of problems for patient GMPDFN
; in GMPL(#)=ifn^status^description^ICD^onset^last modified^SC^SpExp^Condition^Loc^
; loc.type^prov^service
; & 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 I,IFN,CNT,GMPL0,GMPL1,SP,ST,NUM,ONSET,ICD,LASTMOD,PRIO,DTREC
N SC,ORLIST,ORVIEW,GMPARAM,ORTOTAL,LIN,LOC,LT,PROV,SERV,HASCMT
N SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,ORICD186,INACT
Q:$G(GMPDFN)'>0
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")=""
S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
;
D GETPLIST^GMPLMGR1(.ORLIST,.ORTOTAL,.ORVIEW)
;
F NUM=0:0 S NUM=$O(ORLIST(NUM)) Q:NUM'>0 D
. S IFN=+ORLIST(NUM) Q:IFN'>0
. S INACT=""
. S GMPL0=$G(^AUPNPROB(IFN,0))
. S GMPL1=$G(^AUPNPROB(IFN,1))
. S HASCMT=($D(^AUPNPROB(IFN,11,0))>0)
. S CNT=CNT+1
. I +ORICD186 D
. . S ICD=$$CODEC^ICDCODE(+GMPL0)
. . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#"
. E D
. . S ICD=$P($G(^ICD9(+GMPL0,0)),U)
. 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
. S GMPL(CNT)=LIN
S GMPL(0)=CNT
Q
;
;
;------------------------------------- GET LIST OF DELETED PROBLEMS -----------------------------
;
DELLIST(RETURN,GMPDFN) ; GET LIST OF DELETED PROBLEMS
; see GETPLIST^GMPLMGR1 and LIST^GMPUTL2
N S,IFN,I,L0,L1,ST,TXT,ICD,ONSET,MOD,SC,SP,LOC,LT,PROV,SERV,PRIO,HASCMT,DTREC
N SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,ORICD186,INACT
S I=0,S=""
S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
F S S=$O(^AUPNPROB("ACTIVE",GMPDFN,S)) Q:S="" D
. 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))
... Q:L0=""
... S INACT=""
... S L1=$G(^AUPNPROB(IFN,1))
... S ST=$P(L0,U,12)
... S TXT=$$PROBTEXT^GMPLX(IFN)
... I +ORICD186 D
... . S ICD=$$CODEC^ICDCODE(+L0)
... . I '+$$STATCHK^ICDAPIU(ICD,DT) S INACT="#"
... E D
... . S ICD=$P($G(^ICD9(+L0,0)),U)
... 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
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(TMP,ORDUZ,CLIN) ; Get user category list
N GSEQ,GCNT,GROUP,HDR,IFN,LCNT,ITEM,TG,GMPLSLST
; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing
S TG=$NAME(TMP) ; put list in local
K @TG
S (GSEQ,GCNT,LCNT)=0
;
S GMPLSLST=$$GETUSLST(DUZ,CLIN) ; get approp list for user
; Build multiple of category\problems
; Iterate categories
F S GSEQ=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ)) Q:GSEQ'>0 D
. S IFN=$O(^GMPL(125.1,"C",+GMPLSLST,GSEQ,0)) Q:IFN'>0
. S ITEM=$G(^GMPL(125.1,IFN,0))
. S GROUP=+$P(ITEM,U,3)
. S HDR=GROUP_U_$P(ITEM,U,4,5)
. S GCNT=GCNT+1
. S @TG@(GCNT)=HDR ; put category into temp global
Q
;
GETUSLST(ORDUZ,CLIN) ; GET AN APPROPRIATE CATEGORY LIST FOR THE USER
N GMPLSLST
S GMPLSLST=$P($G(^VA(200,DUZ,125)),U,2)
;I 'GMPLSLST D
I 'GMPLSLST,CLIN,$D(^GMPL(125,"C",+CLIN)) S GMPLSLST=$O(^(+CLIN,0))
;. S GMPLSLST=$O(^VA(200,DUZ,+CLIN,0)) ;$O(^(+CLIN,0))
Q GMPLSLST
;
;----------------------- USER PROBLEM LIST --------------------------
;
PROB(TMP,GROUP) ; Get user problem list for given group
N PSEQ,PCNT,IFN,ITEM,TG,CODE,TEXT,ORICD186
; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing
S TG=$NAME(TMP) ; put list in local
K @TG
S LCNT=0
S ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
;
; iterate through problems in category
S (PSEQ,PCNT)=0
F S PSEQ=$O(^GMPL(125.12,"C",GROUP,PSEQ)) Q:PSEQ'>0 D
. S IFN=$O(^GMPL(125.12,"C",GROUP,PSEQ,0)) Q:IFN'>0
. S ITEM=$G(^GMPL(125.12,IFN,0))
. S TEXT=$P(ITEM,U,4)
. ; SEE DD for GMPL(125.12,4 :
. ; "...code which is to be displayed... generally assumed to be ICD"
. S CODE=$P(ITEM,U,5)
. I +ORICD186,'+$$STATCHK^ICDAPIU(CODE,DT) Q
. S PCNT=PCNT+1
. ; RETURN:
. ; PROBLEM^DISPLAY TEXT^CODE^CODE IFN
. I +ORICD186 D
. . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$CODEN^ICDCODE(CODE,80)
. E D
. . S @TG@(PCNT)=$P(ITEM,U,3,5)_U_$$ICDCODE(CODE)
Q
;
ICDCODE(COD) ; RETURN INTERNAL ICD FOR EXTERNAL CODE (obsolete after CSV patches released - RV)
N CODIEN
I COD="" Q ""
S CODIEN=+$O(^ICD9("AB",$P(COD,U)_" ",0))
S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",$P(COD,U)_"0 ",0))
Q CODIEN
;
;------------------ 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
ORQQPL3 ; ALB/PDR/REV ; Problem List RPC's ; 8-OCT-1998 09:08:49.29
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,148,173,243**;Dec 17, 1997;Build 242
+2 ;
+3 ;---------------- LIST PATIENT PROBLEMS ------------------------
+4 ;
PROBL(ROOT,DFN,CONTEXT) ; GET LIST OF PATIENT PROBLEMS
+1 NEW DIWL,DIWR,DIWF
+2 NEW ST,ORI,ORX
+3 SET (LCNT,NUM)=0
+4 SET DIWL=1
SET DIWR=48
SET DIWF="C48"
+5 SET CONTEXT=";;"_$GET(CONTEXT)
+6 IF CONTEXT=";;"
SET CONTEXT=";;A"
+7 SET ST=$PIECE(CONTEXT,";",3)
+8 ;
+9 ; show deleted only
IF ST="R"
DO DELLIST(.ROOT,+DFN)
+10 ; show others - don't trust ELSE here
IF ST'="R"
DO LIST(.ROOT,+DFN,ST)
+11 ;
+12 IF ROOT(0)<1
Begin DoDot:1
+13 SET LCNT=1
+14 SET ROOT(1)=" "_$$PAD^ORCHTAB("No data available.",49)_"|"
End DoDot:1
+15 QUIT
+16 ;
+17 ;
LIST(GMPL,GMPDFN,GMPSTAT) ; -- 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
+3 ; & GMPL(0)=number of problems returned
+4 ; This is virtually same as LIST^GMPLUTL2 except that it appends the
+5 ; condition - T)ranscribed or P)ermanent,location,loc type,provider, service.
+6 ;
+7 NEW I,IFN,CNT,GMPL0,GMPL1,SP,ST,NUM,ONSET,ICD,LASTMOD,PRIO,DTREC
+8 NEW SC,ORLIST,ORVIEW,GMPARAM,ORTOTAL,LIN,LOC,LT,PROV,SERV,HASCMT
+9 NEW SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,ORICD186,INACT
+10 IF $GET(GMPDFN)'>0
QUIT
+11 SET CNT=0
SET SP=""
+12 SET GMPARAM("QUIET")=1
+13 SET GMPARAM("REV")=$PIECE($GET(^GMPL(125.99,1,0)),U,5)="R"
+14 SET ORVIEW("ACT")=GMPSTAT
+15 SET ORVIEW("PROV")=0
+16 SET ORVIEW("VIEW")=""
+17 SET ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
+18 ;
+19 DO GETPLIST^GMPLMGR1(.ORLIST,.ORTOTAL,.ORVIEW)
+20 ;
+21 FOR NUM=0:0
SET NUM=$ORDER(ORLIST(NUM))
IF NUM'>0
QUIT
Begin DoDot:1
+22 SET IFN=+ORLIST(NUM)
IF IFN'>0
QUIT
+23 SET INACT=""
+24 SET GMPL0=$GET(^AUPNPROB(IFN,0))
+25 SET GMPL1=$GET(^AUPNPROB(IFN,1))
+26 SET HASCMT=($DATA(^AUPNPROB(IFN,11,0))>0)
+27 SET CNT=CNT+1
+28 IF +ORICD186
Begin DoDot:2
+29 SET ICD=$$CODEC^ICDCODE(+GMPL0)
+30 IF '+$$STATCHK^ICDAPIU(ICD,DT)
SET INACT="#"
End DoDot:2
+31 IF '$TEST
Begin DoDot:2
+32 SET ICD=$PIECE($GET(^ICD9(+GMPL0,0)),U)
End DoDot:2
+33 SET LASTMOD=$PIECE(GMPL0,U,3)
+34 SET ST=$PIECE(GMPL0,U,12)
+35 SET ONSET=$PIECE(GMPL0,U,13)
+36 SET SC=$SELECT(+$PIECE(GMPL1,U,10):"SC",$PIECE(GMPL1,U,10)=0:"NSC",1:"")
+37 SET AO=$SELECT(+$PIECE(GMPL1,U,11):"/AO",1:"")
+38 SET IR=$SELECT(+$PIECE(GMPL1,U,12):"/IR",1:"")
+39 SET ENV=$SELECT(+$PIECE(GMPL1,U,13):"/EC",1:"")
+40 SET HNC=$SELECT(+$PIECE(GMPL1,U,15):"/HNC",1:"")
+41 SET MST=$SELECT(+$PIECE(GMPL1,U,16):"/MST",1:"")
+42 SET CV=$SELECT(+$PIECE(GMPL1,U,17):"/CV",1:"")
+43 SET SHD=$SELECT(+$PIECE(GMPL1,U,18):"/SHD",1:"")
+44 SET SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD
+45 SET LOC=$PIECE(GMPL1,U,8)
+46 SET DTREC=$PIECE(GMPL1,U,9)
+47 SET LT=""
+48 IF LOC'=""
SET LT=$PIECE($GET(^SC(LOC,0)),"^",3)
SET LOC=LOC_";"_$PIECE($GET(^SC(LOC,0)),U,1)
+49 ; responsible provider
SET PROV=$PIECE(GMPL1,U,5)
+50 IF PROV'=""
SET PROV=PROV_";"_$PIECE($GET(^VA(200,PROV,0)),U,1)
+51 SET SERV=$PIECE(GMPL1,U,6)
+52 ; not sure how it gets set to 0, but need consistency in GUI
IF SERV=0
SET SERV=""
+53 IF SERV'=""
SET SERV=SERV_";"_$PIECE($GET(^DIC(49,SERV,0)),U,1)
+54 SET SP=""
+55 FOR I=11,12,13
IF $PIECE(GMPL1,U,I)
SET SP=SP_$SELECT(I=11:"A",I=12:"I",1:"P")
+56 SET PRIO=$PIECE(GMPL1,U,14)
+57 SET LIN=IFN_U_ST_U_$$PROBTEXT^GMPLX(IFN)_U_ICD_U_ONSET
+58 SET LIN=LIN_U_LASTMOD_U_SC_U_SP_U_$PIECE(GMPL1,U,2)
+59 SET LIN=LIN_U_LOC_U_LT_U_PROV_U_SERV_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT
+60 SET GMPL(CNT)=LIN
End DoDot:1
+61 SET GMPL(0)=CNT
+62 QUIT
+63 ;
+64 ;
+65 ;------------------------------------- GET LIST OF DELETED PROBLEMS -----------------------------
+66 ;
DELLIST(RETURN,GMPDFN) ; GET LIST OF DELETED PROBLEMS
+1 ; see GETPLIST^GMPLMGR1 and LIST^GMPUTL2
+2 NEW S,IFN,I,L0,L1,ST,TXT,ICD,ONSET,MOD,SC,SP,LOC,LT,PROV,SERV,PRIO,HASCMT,DTREC
+3 NEW SCCOND,AO,IR,ENV,HNC,MST,CV,SHD,ORICD186,INACT
+4 SET I=0
SET S=""
+5 SET ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
+6 FOR
SET S=$ORDER(^AUPNPROB("ACTIVE",GMPDFN,S))
IF S=""
QUIT
Begin DoDot:1
+7 SET IFN=""
+8 FOR
SET IFN=$ORDER(^AUPNPROB("ACTIVE",+GMPDFN,S,IFN))
IF IFN=""
QUIT
Begin DoDot:2
+9 IF $PIECE($GET(^AUPNPROB(IFN,1)),U,2)="H"
Begin DoDot:3
+10 SET L0=$GET(^AUPNPROB(IFN,0))
+11 IF L0=""
QUIT
+12 SET INACT=""
+13 SET L1=$GET(^AUPNPROB(IFN,1))
+14 SET ST=$PIECE(L0,U,12)
+15 SET TXT=$$PROBTEXT^GMPLX(IFN)
+16 IF +ORICD186
Begin DoDot:4
+17 SET ICD=$$CODEC^ICDCODE(+L0)
+18 IF '+$$STATCHK^ICDAPIU(ICD,DT)
SET INACT="#"
End DoDot:4
+19 IF '$TEST
Begin DoDot:4
+20 SET ICD=$PIECE($GET(^ICD9(+L0,0)),U)
End DoDot:4
+21 SET ONSET=$PIECE(L0,U,13)
+22 SET MOD=$PIECE(L0,U,3)
+23 SET SC=$SELECT(+$PIECE(L1,U,10):"SC",$PIECE(L1,U,10)=0:"NSC",1:"")
+24 SET AO=$SELECT(+$PIECE(L1,U,11):"/AO",1:"")
+25 SET IR=$SELECT(+$PIECE(L1,U,12):"/IR",1:"")
+26 SET ENV=$SELECT(+$PIECE(L1,U,13):"/EC",1:"")
+27 SET HNC=$SELECT(+$PIECE(L1,U,15):"/HNC",1:"")
+28 SET MST=$SELECT(+$PIECE(L1,U,16):"/MST",1:"")
+29 SET CV=$SELECT(+$PIECE(L1,U,17):"/CV",1:"")
+30 SET SHD=$SELECT(+$PIECE(L1,U,18):"/SHD",1:"")
+31 SET SCCOND=SC_AO_IR_ENV_HNC_MST_CV_SHD
+32 SET SP=$$GETSP
+33 SET LOC=$PIECE(L1,U,8)
+34 SET LT=""
+35 IF LOC'=""
SET LT=$PIECE($GET(^SC(LOC,0)),"^",3)
+36 ; responsible provider
SET PROV=$PIECE(L1,U,5)
+37 SET SERV=$PIECE(L1,U,6)
+38 SET PRIO=$PIECE(L1,U,14)
+39 SET HASCMT=($DATA(^AUPNPROB(IFN,11,0))>0)
+40 SET DTREC=$PIECE(L1,U,9)
+41 SET I=I+1
+42 SET RETURN(I)=IFN_U_ST_U_TXT_U_ICD_U_ONSET
+43 SET RETURN(I)=RETURN(I)_U_MOD_U_SC_U_SP_U_$PIECE(L1,U,2)
+44 SET RETURN(I)=RETURN(I)_U_LOC_U_LT_U_PROV_U_SERV
+45 SET RETURN(I)=RETURN(I)_U_PRIO_U_HASCMT_U_DTREC_U_SCCOND_U_INACT
End DoDot:3
End DoDot:2
End DoDot:1
+46 SET RETURN(0)=I
+47 QUIT
+48 ;
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(TMP,ORDUZ,CLIN) ; Get user category list
+1 NEW GSEQ,GCNT,GROUP,HDR,IFN,LCNT,ITEM,TG,GMPLSLST
+2 ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing
+3 ; put list in local
SET TG=$NAME(TMP)
+4 KILL @TG
+5 SET (GSEQ,GCNT,LCNT)=0
+6 ;
+7 ; get approp list for user
SET GMPLSLST=$$GETUSLST(DUZ,CLIN)
+8 ; Build multiple of category\problems
+9 ; Iterate categories
+10 FOR
SET GSEQ=$ORDER(^GMPL(125.1,"C",+GMPLSLST,GSEQ))
IF GSEQ'>0
QUIT
Begin DoDot:1
+11 SET IFN=$ORDER(^GMPL(125.1,"C",+GMPLSLST,GSEQ,0))
IF IFN'>0
QUIT
+12 SET ITEM=$GET(^GMPL(125.1,IFN,0))
+13 SET GROUP=+$PIECE(ITEM,U,3)
+14 SET HDR=GROUP_U_$PIECE(ITEM,U,4,5)
+15 SET GCNT=GCNT+1
+16 ; put category into temp global
SET @TG@(GCNT)=HDR
End DoDot:1
+17 QUIT
+18 ;
GETUSLST(ORDUZ,CLIN) ; GET AN APPROPRIATE CATEGORY LIST FOR THE USER
+1 NEW GMPLSLST
+2 SET GMPLSLST=$PIECE($GET(^VA(200,DUZ,125)),U,2)
+3 ;I 'GMPLSLST D
+4 IF 'GMPLSLST
IF CLIN
IF $DATA(^GMPL(125,"C",+CLIN))
SET GMPLSLST=$ORDER(^(+CLIN,0))
+5 ;. S GMPLSLST=$O(^VA(200,DUZ,+CLIN,0)) ;$O(^(+CLIN,0))
+6 QUIT GMPLSLST
+7 ;
+8 ;----------------------- USER PROBLEM LIST --------------------------
+9 ;
PROB(TMP,GROUP) ; Get user problem list for given group
+1 NEW PSEQ,PCNT,IFN,ITEM,TG,CODE,TEXT,ORICD186
+2 ; S TG=$NAME(^TMP("GMPLMENU",$J)) ; put list in global for testing
+3 ; put list in local
SET TG=$NAME(TMP)
+4 KILL @TG
+5 SET LCNT=0
+6 SET ORICD186=$$PATCH^XPDUTL("ICD*18.0*6")
+7 ;
+8 ; iterate through problems in category
+9 SET (PSEQ,PCNT)=0
+10 FOR
SET PSEQ=$ORDER(^GMPL(125.12,"C",GROUP,PSEQ))
IF PSEQ'>0
QUIT
Begin DoDot:1
+11 SET IFN=$ORDER(^GMPL(125.12,"C",GROUP,PSEQ,0))
IF IFN'>0
QUIT
+12 SET ITEM=$GET(^GMPL(125.12,IFN,0))
+13 SET TEXT=$PIECE(ITEM,U,4)
+14 ; SEE DD for GMPL(125.12,4 :
+15 ; "...code which is to be displayed... generally assumed to be ICD"
+16 SET CODE=$PIECE(ITEM,U,5)
+17 IF +ORICD186
IF '+$$STATCHK^ICDAPIU(CODE,DT)
QUIT
+18 SET PCNT=PCNT+1
+19 ; RETURN:
+20 ; PROBLEM^DISPLAY TEXT^CODE^CODE IFN
+21 IF +ORICD186
Begin DoDot:2
+22 SET @TG@(PCNT)=$PIECE(ITEM,U,3,5)_U_$$CODEN^ICDCODE(CODE,80)
End DoDot:2
+23 IF '$TEST
Begin DoDot:2
+24 SET @TG@(PCNT)=$PIECE(ITEM,U,3,5)_U_$$ICDCODE(CODE)
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
ICDCODE(COD) ; RETURN INTERNAL ICD FOR EXTERNAL CODE (obsolete after CSV patches released - RV)
+1 NEW CODIEN
+2 IF COD=""
QUIT ""
+3 SET CODIEN=+$ORDER(^ICD9("AB",$PIECE(COD,U)_" ",0))
+4 IF CODIEN'>0
SET CODIEN=+$ORDER(^ICD9("AB",$PIECE(COD,U)_"0 ",0))
+5 QUIT CODIEN
+6 ;
+7 ;------------------ Filter Providers ---------------------
+8 ;
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
