ORQQPL1 ; ALB/PDR,REV,ISL/JER,TC,LAB - PROBLEM LIST FOR CPRS GUI ;04/25/19 09:27
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,148,173,203,206,249,243,280,306,361,385,350,479,377**;Dec 17, 1997;Build 582
;
;------------------------- GET PROBLEM FROM LEXICON -------------------
;
LEXSRCH(LIST,FROM,N,VIEW,ORDATE) ; Get candidate Problems from LEX file
N LEX,VAL,VAL1,COD,CIEN,SYS,MAX,NAME,ORIMPDT,ICDCSYS,ICDCODE
S ORIMPDT=$$IMPDATE^LEXU("10D")
S:'+$G(ORDATE) ORDATE=DT
S:'$G(N) N=100
S:'$L($G(VIEW)) VIEW="PL1"
D CONFIG^LEXSET("GMPL",VIEW,ORDATE)
D LOOK^LEXA(FROM,"GMPL",N,"",ORDATE)
S S=0
F S S=$O(LEX("LIST",S)) Q:S<1 D
. S VAL1=LEX("LIST",S)
. S COD="",CIEN="",SYS="",NAME="",ICDCODE=""
. S ICDCSYS=$S(ORDATE<ORIMPDT:"ICD",1:"10D")
. I $L(VAL1,"CPT-4 ")>1 D
.. S SYS=$S(ORDATE<ORIMPDT:"ICD-9-CM ",1:"ICD-10-CM ")
.. S COD=$S(ORDATE<ORIMPDT:"799.9",1:"R69")
.. S CIEN=""
.. S NAME=$P(VAL1," (CPT-4")
. I $L(VAL1,"DSM-IV ")>1 D
.. S SYS="DSM-IV "
.. S COD=$P($P(VAL1,SYS,2),")")
.. S:COD["/" COD=$P(COD,"/",1)
.. S ICDCODE=$$ONE^LEXU($P(VAL1,U,1),ORDATE,ICDCSYS)
.. S ICDCODE=$S(ICDCODE["":COD,1:ICDCODE)
.. S CIEN=+$$ICDDATA^ICDXCODE(ICDCSYS,$G(ICDCODE),ORDATE,"E")
.. S NAME=$P(VAL1," (DSM-IV")
.. ;
. I $L(VAL1,"(TITLE 38 ")>1 D
.. S SYS="TITLE 38 "
.. S COD=$P($P(VAL1,SYS,2),")")
.. S:COD["/" COD=$P(COD,"/",1)
.. S ICDCODE=$$ONE^LEXU($P(VAL1,U,1),ORDATE,ICDCSYS)
.. S ICDCODE=$S(ICDCODE["":COD,1:ICDCODE)
.. S CIEN=+$$ICDDATA^ICDXCODE(ICDCSYS,$G(ICDCODE),ORDATE,"E")
.. S NAME=$P(VAL1,"(TITLE 38 ")
.. ;
. I $L(VAL1,"ICD-9-CM ")>1 D
.. S SYS="ICD-9-CM "
.. S COD=$P($P(VAL1,SYS,2),")")
.. S:COD["/" COD=$P(COD,"/",1)
.. S CIEN=+$$ICDDATA^ICDXCODE("DIAG",$G(COD),ORDATE,"E")
.. S NAME=$P(VAL1," (ICD-9-CM")
.. ;
. I $L(VAL1,"ICD-10-CM ")>1 D
.. S SYS="ICD-10-CM "
.. S COD=$P($P(VAL1,SYS,2),")")
.. S:COD["/" COD=$P(COD,"/",1)
.. S CIEN=+$$ICDDATA^ICDXCODE("DIAG",$G(COD),ORDATE,"E")
.. S NAME=$P(VAL1," (ICD-10-CM")
. I $L(NAME)=0 S NAME=$P($P(VAL1," (")," *")
. ;
. ; jeh Clean left over codes
. S NAME=$P(NAME," (CPT-4")
. S NAME=$P(NAME," (DSM-IV")
. S NAME=$P(NAME,"(TITLE 38 ")
. S NAME=$P(NAME," (ICD-9-CM")
. S NAME=$P(NAME," (ICD-10-CM")
. ;
. S VAL=NAME_U_COD_U_CIEN_U_SYS ; ien^.01^icd^icdifn^system
. S LIST(S)=VAL
. S MAX=S
I $G(MAX)'="" S LIST(MAX+1)=$G(LEX("MAT"))
K ^TMP("LEXSCH",$J)
Q
;
SORT(LEX) ; Sort terms alphabetically
N ORI S ORI=0
F S ORI=$O(LEX("LIST",ORI)) Q:+ORI'>0 S LEX("ALPHA",$E($P(LEX("LIST",ORI),U,2),1,255),ORI)=""
Q
;
ICDREC(COD) ;
N CODIEN,ICDCSYS
I COD="" Q ""
S COD=$P($P(COD,U),"/")
S ICDCSYS=$$SAB^ICDEX(+$$CODECS^ICDEX($G(COD),80,DT),DT) ;ICR #5747
S CODIEN=+$$ICDDATA^ICDXCODE(ICDCSYS,$G(COD),DT,"E") ;ICR #5699
Q CODIEN
;
CPTREC(COD) ;
I COD="" Q ""
Q $$CODEN^ICPTCOD(COD) ;ICR #1995
;
EDLOAD(RETURN,DA) ; LOAD EDIT ARRAYS
; DA=problem IFN
N I,GMPFLD,GMPORIG,GMPL
D GETFLDS^GMPLEDT3(DA)
S I=0
D LOADFLDS(.RETURN,"GMPFLD","NEW",.I)
D LOADFLDS(.RETURN,"GMPORIG","ORG",.I)
K GMPFLD,GMPORIG,GMPL ; should not have to do this
Q
;
LOADFLDS(RETURN,NAM,TYP,I) ; LOAD FIELDS FOR TYPE OF ARRAY
N S,V,CVP,PN,PID
S S="",V=$C(254)
F S S=$O(@NAM@(S)) Q:S=10 D
. S RETURN(I)=TYP_V_S_V_@NAM@(S)
. S I=I+1
S S=""
F S S=$O(@NAM@(10,S)) Q:S="" D
. S CVP=@NAM@(10,S)
. S PN="" ; provider name
. S PID=$P(CVP,U,6) ; provider id
. I PID'="" S PN=$$GET1^DIQ(200,PID,.01) ; get provider name
. S RETURN(I)=TYP_V_"10,"_S_V_CVP_U_PN
. S I=I+1
S S=80000
F S S=$O(@NAM@(S)) Q:S="" D
. S RETURN(I)=TYP_V_S_V_@NAM@(S)
. S I=I+1
Q
;
EDSAVE(RETURN,GMPIFN,GMPROV,GMPVAMC,UT,EDARRAY,GMPSRCH) ; SAVE EDITED RES
; RETURN - boolean, 1 success, 0 failure
; EDARRAY - array used for indirect sets of GMPORIG() and GMPFLDS()
;
N GMPFLD,GMPORIG,S,GMPLUSER
N VSRQFLG ; lab OR*3.0*479 added new variable
S VSRQFLG=0
S GMPSRCH=$G(GMPSRCH)
S RETURN=1 ; initialize for success
I UT S GMPLUSER=1
;
S S=""
F S S=$O(EDARRAY(S)) Q:S="" D
. ;S @EDARRAY(S) D lab OR*3.0*479 commented out EDDARRAY and added new logic below
. ; lab OR*3.0*479 Adding data checks to prevent backdoor access into VistA
. ; lab - start new logic OR*3.0*479
. I ($E(EDARRAY(S),1,6)="GMPFLD")!($E(EDARRAY(S),1,7)="GMPORIG") D
. . I $E(EDARRAY(S),$F(EDARRAY(S),"="))="""" D
. . . S @EDARRAY(S)
. . ELSE D
. . . S RETURN=0
. . . S VSRQFLG=1
. ELSE D
. . S RETURN=0
. . S VSRQFLG=1
;
Q:(VSRQFLG) ;quit if flag has been set meaning an unexpected value was sent in the parameter.
; lab - end new logic OR*3.0*479
I $D(GMPFLD(10,"NEW"))>9 D I 'RETURN Q ; Bail Out if no lock
. L +^AUPNPROB(GMPIFN,11):10 ; given bogus nature of this lock, should be able to get
. I '$T S RETURN=0
;
D EN^GMPLSAVE ; save the data
K GMPFLD,GMPORIG
;
L -^AUPNPROB(GMPIFN,11) ; free this instance of lock (in case it was set)
S RETURN=1
Q
;
UPDATE(ORRETURN,UPDARRAY) ; UPDATE A PROBLEM RECORD
; Does essentially same job as EDSAVE above, however does not handle edits to comments
; or addition of multiple comments.
; Use initially just for status updates.
;
N S,GMPL,GMPORIG,ORARRAY ; last 2 vars created in nested call
N VSRQFLG ; lab OR*3.0*479 added new variable
S VSRQFLG=0
S S=""
F S S=$O(UPDARRAY(S)) Q:S="" D
. ;S @UPDARRAY(S) lab OR*3.0*479 commented out UPDARRAY and added new logic below
. ; lab OR*3.0*479 Adding data checks to prevent backdoor access into VistA
. ; lab - start new logic OR*3.0*479
. I ($E(UPDARRAY(S),1,7)="ORARRAY") D
. . I $E(UPDARRAY(S),$F(UPDARRAY(S),"="))="""" D
. . . S @UPDARRAY(S)
. . ELSE D
. . . S ORRETURN(0)=0
. . . S ORRETURN(1)="Unexpected array value."
. . . S VSRQFLG=1
. ELSE D
. . S ORRETURN(0)=0
. . S ORRETURN(1)="Unexpected array value."
. . S VSRQFLG=1
;
Q:(VSRQFLG) ;quit if flag has been set meaning an unexpected value was sent in the parameter.
; lab - end new logic OR*3.0*479
D UPDATE^GMPLUTL(.ORARRAY,.ORRETURN)
; broker wont pick up root node RETURN
S ORRETURN(1)=ORRETURN(0) ; error text
S ORRETURN(0)=ORRETURN ; gmpdfn
I ORRETURN(0)="" S ORRETURN=1 ; insurance ? need
Q
;
ADDSAVE(RETURN,GMPDFN,GMPROV,GMPVAMC,ADDARRAY,GMPSRCH) ; SAVE NEW RECORD
; RETURN - Problem IFN if success, 0 otherwise
; ADDARRAY - array used for indirect sets of GMPFLDS()
;
N DA,GMPFLD,GMPORIG,S
N VSRQFLG ; lab OR*3.0*479 added new variable
S VSRQFLG=0
S GMPSRCH=$G(GMPSRCH)
S RETURN=0 ;
L +^AUPNPROB(0):10
Q:'$T ; bail out if no lock
;
S S=""
F S S=$O(ADDARRAY(S)) Q:S="" D
. ; lab - S @ADDARRAY(S) OR*3.0*479 commented out ADDARRAY and added new logic below
. ; lab - for VSR project, adding data checks to prevent backdoor access into VistA
. ; lab - start new logic
. I $E(ADDARRAY(S),1,6)="GMPFLD" D
. . I $E(ADDARRAY(S),$F(ADDARRAY(S),"="))="""" D
. . . S @ADDARRAY(S)
. . ELSE D
. . . S RETURN=0
. . . L -^AUPNPROB(0)
. . . S VSRQFLG=1
. ELSE D
. . S RETURN=0
. . L -^AUPNPROB(0)
. . S VSRQFLG=1
;
Q:(VSRQFLG) ;quit if flag has been set meaning an unexpected value was sent in the parameter.
; lab - end new logic OR*3.0*479
;
D NEW^GMPLSAVE
;
S RETURN=DA
;
L -^AUPNPROB(0)
S RETURN=1
Q
;
INITUSER(RETURN,ORDUZ) ; INITIALIZE FOR NEW USER
; taken from INIT^GMPLMGR
; leave GMPLUSER on symbol table - is evaluated in EDITSAVE
;
N X,PV,CTXT,GMPLPROV,ORENT
S ORDUZ=$G(ORDUZ,DUZ)
S GMPLUSER=$$CLINUSER(ORDUZ)
S CTXT=$$GET^XPAR("ALL","ORCH CONTEXT PROBLEMS",1)
S X=$G(^GMPL(125.99,1,0)) ; IN1+6^GMPLMGR
S RETURN(0)=GMPLUSER ; problem list user, or other user
S RETURN(1)=$$VIEW^GMPLX1(ORDUZ) ; GMPLVIEW("VIEW") - users default view
S RETURN(2)=+$P(X,U,2) ; verify transcribed problems
S RETURN(3)=+$P(X,U,3) ; prompt for chart copy
S RETURN(4)=+$P(X,U,4) ; use lexicon
S RETURN(5)=$S($P(X,U,5)="R":1,1:0) ; chron or reverse chron listing
S RETURN(6)=$S($P($G(CTXT),";",3)'="":$P($G(CTXT),";",3),1:"A")
S GMPLPROV=$P($G(CTXT),";",5)
I +GMPLPROV>0,$D(^VA(200,GMPLPROV)) D
. S RETURN(7)=GMPLPROV_U_$P(^VA(200,GMPLPROV,0),U)
E S RETURN(7)="0^All"
S RETURN(8)=$$SERVICE^GMPLX1(ORDUZ) ; user's service/section
; Guessing from what I see in the data that $$VIEW^GMPLX1 actually returns a composite
; of default view (in/out patient)/(c1/c2... if out patient i.e. GMPLVIEW("CLIN")) or
; /(s1/s2... if in patient i.e. GMPLVIEW("SERV"))
; Going with this assumption for now:
I $L(RETURN(1),"/")>1 D
. S PV=RETURN(1)
. S RETURN(1)=$P(PV,"/")
. I RETURN(1)="C" S GMPLVIEW("CLIN")=$P(PV,"/",2,99)
. I RETURN(1)="S" S GMPLVIEW("SERV")=$P(PV,"/",2,99)
S RETURN(9)=$G(GMPLVIEW("SERV")) ; ??? Where from - see tech doc
S RETURN(10)=$G(GMPLVIEW("CLIN")) ; ??? Where from - see tech doc
S RETURN(11)=""
S RETURN(12)=+$P($G(CTXT),";",4) ; should comments display?
S ORENT="ALL^SRV.`"_+$$SERVICE^GMPLX1(ORDUZ,1)
S RETURN(13)=+$$GET^XPAR(ORENT,"ORQQPL SUPPRESS CODES",1) ; suppress codes?
K GMPLVIEW
Q
;
CLINUSER(ORDUZ) ;is this a clinical user?
N ORUSER
S ORUSER=0
I $D(^XUSEC("ORES",ORDUZ)) S ORUSER=1
I $D(^XUSEC("ORELSE",ORDUZ)) S ORUSER=1
I $D(^XUSEC("PROVIDER",ORDUZ)) S ORUSER=1
Q ORUSER
;
INITPT(RETURN,DFN) ; GET PATIENT PARAMETERS
Q:+$G(DFN)=0
N GMPSC,GMPAGTOR,GMPION,GMPGULF,GMPHNC,GMPMST,GMPCV,GMPSHD
;
S RETURN(0)=DUZ(2) ; facility #
D DEM^VADPT ; get death indicator
S RETURN(1)=$G(VADM(6)) ; death indicator
D VADPT^GMPLX1(DFN) ; get eligibilities
S RETURN(2)=$P(GMPSC,U) ; service connected
S RETURN(3)=$G(GMPAGTOR) ; agent orange exposure
S RETURN(4)=$G(GMPION) ; ionizing radiation exposure
S RETURN(5)=$G(GMPGULF) ; gulf war exposure
S RETURN(6)=VA("BID") ; need this to reconstitute GMPDFN on return
S RETURN(7)=$G(GMPHNC) ; head/neck cancer
S RETURN(8)=$G(GMPMST) ; MST
S RETURN(9)=$G(GMPCV) ; CV
S RETURN(10)=$G(GMPSHD) ; SHAD
Q
;
PROVSRCH(LST,FLAG,N,FROM,PART) ; Get candidate Rroviders from person file
N LV,NS,RV,IEN
S RV=$NAME(LV("DILIST","ID"))
IF +$G(N)=0 S N=50
S FLAG=$G(FLAG),N=$G(N),FROM=$G(FROM),PART=$G(PART)
D LIST^DIC(200,"",".01;1",FLAG,N,FROM,PART,"","","","LV")
S NS=""
F S NS=$O(LV("DILIST",1,NS)) Q:NS="" D
. S IEN=""
. S IEN=$O(^VA(200,"B",@RV@(NS,.01),IEN)) ; compliments of PROV^ORQPTQ
. S LST(NS)=IEN_U_@RV@(NS,.01) ; initials_U_@RV@(NS,1)
Q
;
CLINSRCH(Y,X) ; Get LIST OF CLINICS
; Note: This comes from CLIN^ORQPTQ2, where it was commented out in place of
; a call to ^XPAR. I would have just used CLIN^ORQPTQ2, but it didn't work - at
; least on SLC OEX directory.
; X has no purpose other than to satisfy apparent rpc and tcallv requirement for args
N I,NAME,IEN
S I=1,IEN=0,NAME=""
;access to SC global granted under DBIA #518:
F S NAME=$O(^SC("B",NAME)) Q:NAME="" S IEN=$O(^(NAME,0)) D
. I $P(^SC(IEN,0),"^",3)="C" S Y(I)=IEN_"^"_NAME,I=I+1
Q
;
SRVCSRCH(Y,FROM,DIR,ALL) ; GET LIST OF SERVICES
N I,IEN,CNT S I=0,CNT=44
F Q:I=CNT S FROM=$O(^DIC(49,"B",FROM),DIR) Q:FROM="" D
. S IEN=$O(^DIC(49,"B",FROM,0)) I '$G(ALL),$P(^DIC(49,IEN,0),U,9)'="C" Q
. S I=I+1,Y(I)=IEN_"^"_FROM
Q
;
DUP(Y,DFN,TERM,TEXT) ;Check for duplicate problem
S Y=$$DUPL^GMPLX(DFN,TERM,TEXT) Q:+Y=0
I $P(^AUPNPROB(Y,1),U,2)="H" S Y=0 Q
S Y=Y_U_$P(^AUPNPROB(Y,0),U,12)
Q
GETDX(ORCODE,ORSYS,ORIDT) ; Get ICD associated with SNOMED CT or VHAT Code
N LEX,ORI,ORY,ORUH,ORIMPDT,ORCSYSPR,ORMAP
S ORIDT=$G(ORIDT,DT)
S ORY=0,ORIMPDT=$$IMPDATE^LEXU("10D")
S ORUH=$S(ORIDT<ORIMPDT:"799.9",1:"R69.")
S ORCSYSPR=$S(ORIDT<ORIMPDT:1,1:30)
I ORSYS["VHAT" D I 1
. I ORIDT<ORIMPDT S ORY=$$GETASSN^LEXTRAN1(ORCODE,"VHAT2ICD") I 1
. E S ORY=0
E D
. S ORMAP=$S(ORIDT<ORIMPDT:"SCT2ICD",1:"SCT210D")
. S ORY=$$GETASSN^LEXTRAN1(ORCODE,ORMAP) I 1
. ;I ORIDT<ORIMPDT S ORY=$$GETASSN^LEXTRAN1(ORCODE,"SCT2ICD") I 1 ; ajb IDT is always greater than so ORY always got set to 0 below
. ;E S ORY=0
I $S(+ORY'>0:1,+$P(ORY,U,2)'>0:1,+LEX'>0:1,1:0) S ORY=ORUH G GETDXX
S ORI=0,ORY=""
F S ORI=$O(LEX(ORI)) Q:+ORI'>0 D
. N ORICD
. S ORICD=$O(LEX(ORI,""))
. S ORICD=$S(ORICD'[".":ORICD_".",1:ORICD)
. S:'+$$STATCHK^ICDEX(ORICD,ORIDT,ORCSYSPR) ORICD=""
. I ORICD]"" S ORY=$S(ORY'="":ORY_"/",1:"")_ORICD
I (ORY]""),(ORY'[".") S ORY=ORY_"."
GETDXX Q ORY
TEST ; test invocation
N LIST,I S I=""
D LEXSRCH(.LIST,"diabetes with neuro",10,"GMPL",DT)
F S I=$O(LIST(I)) Q:+I'>0 W !,LIST(I)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORQQPL1 12580 printed Sep 23, 2025@20:09:59 Page 2
ORQQPL1 ; ALB/PDR,REV,ISL/JER,TC,LAB - PROBLEM LIST FOR CPRS GUI ;04/25/19 09:27
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,148,173,203,206,249,243,280,306,361,385,350,479,377**;Dec 17, 1997;Build 582
+2 ;
+3 ;------------------------- GET PROBLEM FROM LEXICON -------------------
+4 ;
LEXSRCH(LIST,FROM,N,VIEW,ORDATE) ; Get candidate Problems from LEX file
+1 NEW LEX,VAL,VAL1,COD,CIEN,SYS,MAX,NAME,ORIMPDT,ICDCSYS,ICDCODE
+2 SET ORIMPDT=$$IMPDATE^LEXU("10D")
+3 if '+$GET(ORDATE)
SET ORDATE=DT
+4 if '$GET(N)
SET N=100
+5 if '$LENGTH($GET(VIEW))
SET VIEW="PL1"
+6 DO CONFIG^LEXSET("GMPL",VIEW,ORDATE)
+7 DO LOOK^LEXA(FROM,"GMPL",N,"",ORDATE)
+8 SET S=0
+9 FOR
SET S=$ORDER(LEX("LIST",S))
if S<1
QUIT
Begin DoDot:1
+10 SET VAL1=LEX("LIST",S)
+11 SET COD=""
SET CIEN=""
SET SYS=""
SET NAME=""
SET ICDCODE=""
+12 SET ICDCSYS=$SELECT(ORDATE<ORIMPDT:"ICD",1:"10D")
+13 IF $LENGTH(VAL1,"CPT-4 ")>1
Begin DoDot:2
+14 SET SYS=$SELECT(ORDATE<ORIMPDT:"ICD-9-CM ",1:"ICD-10-CM ")
+15 SET COD=$SELECT(ORDATE<ORIMPDT:"799.9",1:"R69")
+16 SET CIEN=""
+17 SET NAME=$PIECE(VAL1," (CPT-4")
End DoDot:2
+18 IF $LENGTH(VAL1,"DSM-IV ")>1
Begin DoDot:2
+19 SET SYS="DSM-IV "
+20 SET COD=$PIECE($PIECE(VAL1,SYS,2),")")
+21 if COD["/"
SET COD=$PIECE(COD,"/",1)
+22 SET ICDCODE=$$ONE^LEXU($PIECE(VAL1,U,1),ORDATE,ICDCSYS)
+23 SET ICDCODE=$SELECT(ICDCODE["":COD,1:ICDCODE)
+24 SET CIEN=+$$ICDDATA^ICDXCODE(ICDCSYS,$GET(ICDCODE),ORDATE,"E")
+25 SET NAME=$PIECE(VAL1," (DSM-IV")
+26 ;
End DoDot:2
+27 IF $LENGTH(VAL1,"(TITLE 38 ")>1
Begin DoDot:2
+28 SET SYS="TITLE 38 "
+29 SET COD=$PIECE($PIECE(VAL1,SYS,2),")")
+30 if COD["/"
SET COD=$PIECE(COD,"/",1)
+31 SET ICDCODE=$$ONE^LEXU($PIECE(VAL1,U,1),ORDATE,ICDCSYS)
+32 SET ICDCODE=$SELECT(ICDCODE["":COD,1:ICDCODE)
+33 SET CIEN=+$$ICDDATA^ICDXCODE(ICDCSYS,$GET(ICDCODE),ORDATE,"E")
+34 SET NAME=$PIECE(VAL1,"(TITLE 38 ")
+35 ;
End DoDot:2
+36 IF $LENGTH(VAL1,"ICD-9-CM ")>1
Begin DoDot:2
+37 SET SYS="ICD-9-CM "
+38 SET COD=$PIECE($PIECE(VAL1,SYS,2),")")
+39 if COD["/"
SET COD=$PIECE(COD,"/",1)
+40 SET CIEN=+$$ICDDATA^ICDXCODE("DIAG",$GET(COD),ORDATE,"E")
+41 SET NAME=$PIECE(VAL1," (ICD-9-CM")
+42 ;
End DoDot:2
+43 IF $LENGTH(VAL1,"ICD-10-CM ")>1
Begin DoDot:2
+44 SET SYS="ICD-10-CM "
+45 SET COD=$PIECE($PIECE(VAL1,SYS,2),")")
+46 if COD["/"
SET COD=$PIECE(COD,"/",1)
+47 SET CIEN=+$$ICDDATA^ICDXCODE("DIAG",$GET(COD),ORDATE,"E")
+48 SET NAME=$PIECE(VAL1," (ICD-10-CM")
End DoDot:2
+49 IF $LENGTH(NAME)=0
SET NAME=$PIECE($PIECE(VAL1," (")," *")
+50 ;
+51 ; jeh Clean left over codes
+52 SET NAME=$PIECE(NAME," (CPT-4")
+53 SET NAME=$PIECE(NAME," (DSM-IV")
+54 SET NAME=$PIECE(NAME,"(TITLE 38 ")
+55 SET NAME=$PIECE(NAME," (ICD-9-CM")
+56 SET NAME=$PIECE(NAME," (ICD-10-CM")
+57 ;
+58 ; ien^.01^icd^icdifn^system
SET VAL=NAME_U_COD_U_CIEN_U_SYS
+59 SET LIST(S)=VAL
+60 SET MAX=S
End DoDot:1
+61 IF $GET(MAX)'=""
SET LIST(MAX+1)=$GET(LEX("MAT"))
+62 KILL ^TMP("LEXSCH",$JOB)
+63 QUIT
+64 ;
SORT(LEX) ; Sort terms alphabetically
+1 NEW ORI
SET ORI=0
+2 FOR
SET ORI=$ORDER(LEX("LIST",ORI))
if +ORI'>0
QUIT
SET LEX("ALPHA",$EXTRACT($PIECE(LEX("LIST",ORI),U,2),1,255),ORI)=""
+3 QUIT
+4 ;
ICDREC(COD) ;
+1 NEW CODIEN,ICDCSYS
+2 IF COD=""
QUIT ""
+3 SET COD=$PIECE($PIECE(COD,U),"/")
+4 ;ICR #5747
SET ICDCSYS=$$SAB^ICDEX(+$$CODECS^ICDEX($GET(COD),80,DT),DT)
+5 ;ICR #5699
SET CODIEN=+$$ICDDATA^ICDXCODE(ICDCSYS,$GET(COD),DT,"E")
+6 QUIT CODIEN
+7 ;
CPTREC(COD) ;
+1 IF COD=""
QUIT ""
+2 ;ICR #1995
QUIT $$CODEN^ICPTCOD(COD)
+3 ;
EDLOAD(RETURN,DA) ; LOAD EDIT ARRAYS
+1 ; DA=problem IFN
+2 NEW I,GMPFLD,GMPORIG,GMPL
+3 DO GETFLDS^GMPLEDT3(DA)
+4 SET I=0
+5 DO LOADFLDS(.RETURN,"GMPFLD","NEW",.I)
+6 DO LOADFLDS(.RETURN,"GMPORIG","ORG",.I)
+7 ; should not have to do this
KILL GMPFLD,GMPORIG,GMPL
+8 QUIT
+9 ;
LOADFLDS(RETURN,NAM,TYP,I) ; LOAD FIELDS FOR TYPE OF ARRAY
+1 NEW S,V,CVP,PN,PID
+2 SET S=""
SET V=$CHAR(254)
+3 FOR
SET S=$ORDER(@NAM@(S))
if S=10
QUIT
Begin DoDot:1
+4 SET RETURN(I)=TYP_V_S_V_@NAM@(S)
+5 SET I=I+1
End DoDot:1
+6 SET S=""
+7 FOR
SET S=$ORDER(@NAM@(10,S))
if S=""
QUIT
Begin DoDot:1
+8 SET CVP=@NAM@(10,S)
+9 ; provider name
SET PN=""
+10 ; provider id
SET PID=$PIECE(CVP,U,6)
+11 ; get provider name
IF PID'=""
SET PN=$$GET1^DIQ(200,PID,.01)
+12 SET RETURN(I)=TYP_V_"10,"_S_V_CVP_U_PN
+13 SET I=I+1
End DoDot:1
+14 SET S=80000
+15 FOR
SET S=$ORDER(@NAM@(S))
if S=""
QUIT
Begin DoDot:1
+16 SET RETURN(I)=TYP_V_S_V_@NAM@(S)
+17 SET I=I+1
End DoDot:1
+18 QUIT
+19 ;
EDSAVE(RETURN,GMPIFN,GMPROV,GMPVAMC,UT,EDARRAY,GMPSRCH) ; SAVE EDITED RES
+1 ; RETURN - boolean, 1 success, 0 failure
+2 ; EDARRAY - array used for indirect sets of GMPORIG() and GMPFLDS()
+3 ;
+4 NEW GMPFLD,GMPORIG,S,GMPLUSER
+5 ; lab OR*3.0*479 added new variable
NEW VSRQFLG
+6 SET VSRQFLG=0
+7 SET GMPSRCH=$GET(GMPSRCH)
+8 ; initialize for success
SET RETURN=1
+9 IF UT
SET GMPLUSER=1
+10 ;
+11 SET S=""
+12 FOR
SET S=$ORDER(EDARRAY(S))
if S=""
QUIT
Begin DoDot:1
+13 ;S @EDARRAY(S) D lab OR*3.0*479 commented out EDDARRAY and added new logic below
+14 ; lab OR*3.0*479 Adding data checks to prevent backdoor access into VistA
+15 ; lab - start new logic OR*3.0*479
+16 IF ($EXTRACT(EDARRAY(S),1,6)="GMPFLD")!($EXTRACT(EDARRAY(S),1,7)="GMPORIG")
Begin DoDot:2
+17 IF $EXTRACT(EDARRAY(S),$FIND(EDARRAY(S),"="))=""""
Begin DoDot:3
+18 SET @EDARRAY(S)
End DoDot:3
+19 IF '$TEST
Begin DoDot:3
+20 SET RETURN=0
+21 SET VSRQFLG=1
End DoDot:3
End DoDot:2
+22 IF '$TEST
Begin DoDot:2
+23 SET RETURN=0
+24 SET VSRQFLG=1
End DoDot:2
End DoDot:1
+25 ;
+26 ;quit if flag has been set meaning an unexpected value was sent in the parameter.
if (VSRQFLG)
QUIT
+27 ; lab - end new logic OR*3.0*479
+28 ; Bail Out if no lock
IF $DATA(GMPFLD(10,"NEW"))>9
Begin DoDot:1
+29 ; given bogus nature of this lock, should be able to get
LOCK +^AUPNPROB(GMPIFN,11):10
+30 IF '$TEST
SET RETURN=0
End DoDot:1
IF 'RETURN
QUIT
+31 ;
+32 ; save the data
DO EN^GMPLSAVE
+33 KILL GMPFLD,GMPORIG
+34 ;
+35 ; free this instance of lock (in case it was set)
LOCK -^AUPNPROB(GMPIFN,11)
+36 SET RETURN=1
+37 QUIT
+38 ;
UPDATE(ORRETURN,UPDARRAY) ; UPDATE A PROBLEM RECORD
+1 ; Does essentially same job as EDSAVE above, however does not handle edits to comments
+2 ; or addition of multiple comments.
+3 ; Use initially just for status updates.
+4 ;
+5 ; last 2 vars created in nested call
NEW S,GMPL,GMPORIG,ORARRAY
+6 ; lab OR*3.0*479 added new variable
NEW VSRQFLG
+7 SET VSRQFLG=0
+8 SET S=""
+9 FOR
SET S=$ORDER(UPDARRAY(S))
if S=""
QUIT
Begin DoDot:1
+10 ;S @UPDARRAY(S) lab OR*3.0*479 commented out UPDARRAY and added new logic below
+11 ; lab OR*3.0*479 Adding data checks to prevent backdoor access into VistA
+12 ; lab - start new logic OR*3.0*479
+13 IF ($EXTRACT(UPDARRAY(S),1,7)="ORARRAY")
Begin DoDot:2
+14 IF $EXTRACT(UPDARRAY(S),$FIND(UPDARRAY(S),"="))=""""
Begin DoDot:3
+15 SET @UPDARRAY(S)
End DoDot:3
+16 IF '$TEST
Begin DoDot:3
+17 SET ORRETURN(0)=0
+18 SET ORRETURN(1)="Unexpected array value."
+19 SET VSRQFLG=1
End DoDot:3
End DoDot:2
+20 IF '$TEST
Begin DoDot:2
+21 SET ORRETURN(0)=0
+22 SET ORRETURN(1)="Unexpected array value."
+23 SET VSRQFLG=1
End DoDot:2
End DoDot:1
+24 ;
+25 ;quit if flag has been set meaning an unexpected value was sent in the parameter.
if (VSRQFLG)
QUIT
+26 ; lab - end new logic OR*3.0*479
+27 DO UPDATE^GMPLUTL(.ORARRAY,.ORRETURN)
+28 ; broker wont pick up root node RETURN
+29 ; error text
SET ORRETURN(1)=ORRETURN(0)
+30 ; gmpdfn
SET ORRETURN(0)=ORRETURN
+31 ; insurance ? need
IF ORRETURN(0)=""
SET ORRETURN=1
+32 QUIT
+33 ;
ADDSAVE(RETURN,GMPDFN,GMPROV,GMPVAMC,ADDARRAY,GMPSRCH) ; SAVE NEW RECORD
+1 ; RETURN - Problem IFN if success, 0 otherwise
+2 ; ADDARRAY - array used for indirect sets of GMPFLDS()
+3 ;
+4 NEW DA,GMPFLD,GMPORIG,S
+5 ; lab OR*3.0*479 added new variable
NEW VSRQFLG
+6 SET VSRQFLG=0
+7 SET GMPSRCH=$GET(GMPSRCH)
+8 ;
SET RETURN=0
+9 LOCK +^AUPNPROB(0):10
+10 ; bail out if no lock
if '$TEST
QUIT
+11 ;
+12 SET S=""
+13 FOR
SET S=$ORDER(ADDARRAY(S))
if S=""
QUIT
Begin DoDot:1
+14 ; lab - S @ADDARRAY(S) OR*3.0*479 commented out ADDARRAY and added new logic below
+15 ; lab - for VSR project, adding data checks to prevent backdoor access into VistA
+16 ; lab - start new logic
+17 IF $EXTRACT(ADDARRAY(S),1,6)="GMPFLD"
Begin DoDot:2
+18 IF $EXTRACT(ADDARRAY(S),$FIND(ADDARRAY(S),"="))=""""
Begin DoDot:3
+19 SET @ADDARRAY(S)
End DoDot:3
+20 IF '$TEST
Begin DoDot:3
+21 SET RETURN=0
+22 LOCK -^AUPNPROB(0)
+23 SET VSRQFLG=1
End DoDot:3
End DoDot:2
+24 IF '$TEST
Begin DoDot:2
+25 SET RETURN=0
+26 LOCK -^AUPNPROB(0)
+27 SET VSRQFLG=1
End DoDot:2
End DoDot:1
+28 ;
+29 ;quit if flag has been set meaning an unexpected value was sent in the parameter.
if (VSRQFLG)
QUIT
+30 ; lab - end new logic OR*3.0*479
+31 ;
+32 DO NEW^GMPLSAVE
+33 ;
+34 SET RETURN=DA
+35 ;
+36 LOCK -^AUPNPROB(0)
+37 SET RETURN=1
+38 QUIT
+39 ;
INITUSER(RETURN,ORDUZ) ; INITIALIZE FOR NEW USER
+1 ; taken from INIT^GMPLMGR
+2 ; leave GMPLUSER on symbol table - is evaluated in EDITSAVE
+3 ;
+4 NEW X,PV,CTXT,GMPLPROV,ORENT
+5 SET ORDUZ=$GET(ORDUZ,DUZ)
+6 SET GMPLUSER=$$CLINUSER(ORDUZ)
+7 SET CTXT=$$GET^XPAR("ALL","ORCH CONTEXT PROBLEMS",1)
+8 ; IN1+6^GMPLMGR
SET X=$GET(^GMPL(125.99,1,0))
+9 ; problem list user, or other user
SET RETURN(0)=GMPLUSER
+10 ; GMPLVIEW("VIEW") - users default view
SET RETURN(1)=$$VIEW^GMPLX1(ORDUZ)
+11 ; verify transcribed problems
SET RETURN(2)=+$PIECE(X,U,2)
+12 ; prompt for chart copy
SET RETURN(3)=+$PIECE(X,U,3)
+13 ; use lexicon
SET RETURN(4)=+$PIECE(X,U,4)
+14 ; chron or reverse chron listing
SET RETURN(5)=$SELECT($PIECE(X,U,5)="R":1,1:0)
+15 SET RETURN(6)=$SELECT($PIECE($GET(CTXT),";",3)'="":$PIECE($GET(CTXT),";",3),1:"A")
+16 SET GMPLPROV=$PIECE($GET(CTXT),";",5)
+17 IF +GMPLPROV>0
IF $DATA(^VA(200,GMPLPROV))
Begin DoDot:1
+18 SET RETURN(7)=GMPLPROV_U_$PIECE(^VA(200,GMPLPROV,0),U)
End DoDot:1
+19 IF '$TEST
SET RETURN(7)="0^All"
+20 ; user's service/section
SET RETURN(8)=$$SERVICE^GMPLX1(ORDUZ)
+21 ; Guessing from what I see in the data that $$VIEW^GMPLX1 actually returns a composite
+22 ; of default view (in/out patient)/(c1/c2... if out patient i.e. GMPLVIEW("CLIN")) or
+23 ; /(s1/s2... if in patient i.e. GMPLVIEW("SERV"))
+24 ; Going with this assumption for now:
+25 IF $LENGTH(RETURN(1),"/")>1
Begin DoDot:1
+26 SET PV=RETURN(1)
+27 SET RETURN(1)=$PIECE(PV,"/")
+28 IF RETURN(1)="C"
SET GMPLVIEW("CLIN")=$PIECE(PV,"/",2,99)
+29 IF RETURN(1)="S"
SET GMPLVIEW("SERV")=$PIECE(PV,"/",2,99)
End DoDot:1
+30 ; ??? Where from - see tech doc
SET RETURN(9)=$GET(GMPLVIEW("SERV"))
+31 ; ??? Where from - see tech doc
SET RETURN(10)=$GET(GMPLVIEW("CLIN"))
+32 SET RETURN(11)=""
+33 ; should comments display?
SET RETURN(12)=+$PIECE($GET(CTXT),";",4)
+34 SET ORENT="ALL^SRV.`"_+$$SERVICE^GMPLX1(ORDUZ,1)
+35 ; suppress codes?
SET RETURN(13)=+$$GET^XPAR(ORENT,"ORQQPL SUPPRESS CODES",1)
+36 KILL GMPLVIEW
+37 QUIT
+38 ;
CLINUSER(ORDUZ) ;is this a clinical user?
+1 NEW ORUSER
+2 SET ORUSER=0
+3 IF $DATA(^XUSEC("ORES",ORDUZ))
SET ORUSER=1
+4 IF $DATA(^XUSEC("ORELSE",ORDUZ))
SET ORUSER=1
+5 IF $DATA(^XUSEC("PROVIDER",ORDUZ))
SET ORUSER=1
+6 QUIT ORUSER
+7 ;
INITPT(RETURN,DFN) ; GET PATIENT PARAMETERS
+1 if +$GET(DFN)=0
QUIT
+2 NEW GMPSC,GMPAGTOR,GMPION,GMPGULF,GMPHNC,GMPMST,GMPCV,GMPSHD
+3 ;
+4 ; facility #
SET RETURN(0)=DUZ(2)
+5 ; get death indicator
DO DEM^VADPT
+6 ; death indicator
SET RETURN(1)=$GET(VADM(6))
+7 ; get eligibilities
DO VADPT^GMPLX1(DFN)
+8 ; service connected
SET RETURN(2)=$PIECE(GMPSC,U)
+9 ; agent orange exposure
SET RETURN(3)=$GET(GMPAGTOR)
+10 ; ionizing radiation exposure
SET RETURN(4)=$GET(GMPION)
+11 ; gulf war exposure
SET RETURN(5)=$GET(GMPGULF)
+12 ; need this to reconstitute GMPDFN on return
SET RETURN(6)=VA("BID")
+13 ; head/neck cancer
SET RETURN(7)=$GET(GMPHNC)
+14 ; MST
SET RETURN(8)=$GET(GMPMST)
+15 ; CV
SET RETURN(9)=$GET(GMPCV)
+16 ; SHAD
SET RETURN(10)=$GET(GMPSHD)
+17 QUIT
+18 ;
PROVSRCH(LST,FLAG,N,FROM,PART) ; Get candidate Rroviders from person file
+1 NEW LV,NS,RV,IEN
+2 SET RV=$NAME(LV("DILIST","ID"))
+3 IF +$GET(N)=0
SET N=50
+4 SET FLAG=$GET(FLAG)
SET N=$GET(N)
SET FROM=$GET(FROM)
SET PART=$GET(PART)
+5 DO LIST^DIC(200,"",".01;1",FLAG,N,FROM,PART,"","","","LV")
+6 SET NS=""
+7 FOR
SET NS=$ORDER(LV("DILIST",1,NS))
if NS=""
QUIT
Begin DoDot:1
+8 SET IEN=""
+9 ; compliments of PROV^ORQPTQ
SET IEN=$ORDER(^VA(200,"B",@RV@(NS,.01),IEN))
+10 ; initials_U_@RV@(NS,1)
SET LST(NS)=IEN_U_@RV@(NS,.01)
End DoDot:1
+11 QUIT
+12 ;
CLINSRCH(Y,X) ; Get LIST OF CLINICS
+1 ; Note: This comes from CLIN^ORQPTQ2, where it was commented out in place of
+2 ; a call to ^XPAR. I would have just used CLIN^ORQPTQ2, but it didn't work - at
+3 ; least on SLC OEX directory.
+4 ; X has no purpose other than to satisfy apparent rpc and tcallv requirement for args
+5 NEW I,NAME,IEN
+6 SET I=1
SET IEN=0
SET NAME=""
+7 ;access to SC global granted under DBIA #518:
+8 FOR
SET NAME=$ORDER(^SC("B",NAME))
if NAME=""
QUIT
SET IEN=$ORDER(^(NAME,0))
Begin DoDot:1
+9 IF $PIECE(^SC(IEN,0),"^",3)="C"
SET Y(I)=IEN_"^"_NAME
SET I=I+1
End DoDot:1
+10 QUIT
+11 ;
SRVCSRCH(Y,FROM,DIR,ALL) ; GET LIST OF SERVICES
+1 NEW I,IEN,CNT
SET I=0
SET CNT=44
+2 FOR
if I=CNT
QUIT
SET FROM=$ORDER(^DIC(49,"B",FROM),DIR)
if FROM=""
QUIT
Begin DoDot:1
+3 SET IEN=$ORDER(^DIC(49,"B",FROM,0))
IF '$GET(ALL)
IF $PIECE(^DIC(49,IEN,0),U,9)'="C"
QUIT
+4 SET I=I+1
SET Y(I)=IEN_"^"_FROM
End DoDot:1
+5 QUIT
+6 ;
DUP(Y,DFN,TERM,TEXT) ;Check for duplicate problem
+1 SET Y=$$DUPL^GMPLX(DFN,TERM,TEXT)
if +Y=0
QUIT
+2 IF $PIECE(^AUPNPROB(Y,1),U,2)="H"
SET Y=0
QUIT
+3 SET Y=Y_U_$PIECE(^AUPNPROB(Y,0),U,12)
+4 QUIT
GETDX(ORCODE,ORSYS,ORIDT) ; Get ICD associated with SNOMED CT or VHAT Code
+1 NEW LEX,ORI,ORY,ORUH,ORIMPDT,ORCSYSPR,ORMAP
+2 SET ORIDT=$GET(ORIDT,DT)
+3 SET ORY=0
SET ORIMPDT=$$IMPDATE^LEXU("10D")
+4 SET ORUH=$SELECT(ORIDT<ORIMPDT:"799.9",1:"R69.")
+5 SET ORCSYSPR=$SELECT(ORIDT<ORIMPDT:1,1:30)
+6 IF ORSYS["VHAT"
Begin DoDot:1
+7 IF ORIDT<ORIMPDT
SET ORY=$$GETASSN^LEXTRAN1(ORCODE,"VHAT2ICD")
IF 1
+8 IF '$TEST
SET ORY=0
End DoDot:1
IF 1
+9 IF '$TEST
Begin DoDot:1
+10 SET ORMAP=$SELECT(ORIDT<ORIMPDT:"SCT2ICD",1:"SCT210D")
+11 SET ORY=$$GETASSN^LEXTRAN1(ORCODE,ORMAP)
IF 1
+12 ;I ORIDT<ORIMPDT S ORY=$$GETASSN^LEXTRAN1(ORCODE,"SCT2ICD") I 1 ; ajb IDT is always greater than so ORY always got set to 0 below
+13 ;E S ORY=0
End DoDot:1
+14 IF $SELECT(+ORY'>0:1,+$PIECE(ORY,U,2)'>0:1,+LEX'>0:1,1:0)
SET ORY=ORUH
GOTO GETDXX
+15 SET ORI=0
SET ORY=""
+16 FOR
SET ORI=$ORDER(LEX(ORI))
if +ORI'>0
QUIT
Begin DoDot:1
+17 NEW ORICD
+18 SET ORICD=$ORDER(LEX(ORI,""))
+19 SET ORICD=$SELECT(ORICD'[".":ORICD_".",1:ORICD)
+20 if '+$$STATCHK^ICDEX(ORICD,ORIDT,ORCSYSPR)
SET ORICD=""
+21 IF ORICD]""
SET ORY=$SELECT(ORY'="":ORY_"/",1:"")_ORICD
End DoDot:1
+22 IF (ORY]"")
IF (ORY'[".")
SET ORY=ORY_"."
GETDXX QUIT ORY
TEST ; test invocation
+1 NEW LIST,I
SET I=""
+2 DO LEXSRCH(.LIST,"diabetes with neuro",10,"GMPL",DT)
+3 FOR
SET I=$ORDER(LIST(I))
if +I'>0
QUIT
WRITE !,LIST(I)
+4 QUIT
