ORQQPL1 ; ALB/PDR/REV - PROBLEM LIST FOR CPRS GUI ; 02/12/08
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,148,173,203,206,249,243**;Dec 17, 1997;Build 242
;
;------------------------- 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
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=""
. I $L(VAL1,"CPT-4 ")>1 D
.. S SYS="ICD-9-CM "
.. S COD="799.9"
.. 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 CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80)
.. 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 CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($P(VAL1,U,1),ORDATE),80)
.. 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=+$$CODEN^ICDCODE(COD,80)
.. S NAME=$P(VAL1," (ICD-9-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 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
;
ICDREC(COD) ;
N CODIEN
I COD="" Q ""
S COD=$P($P(COD,U),"/")
S CODIEN=+$O(^ICD9("AB",COD_" ",0))
S:CODIEN'>0 CODIEN=+$O(^ICD9("AB",COD_"0 ",0))
Q CODIEN
;Q $O(^ICD9("BA",COD,""))
;
CPTREC(COD) ;
I COD="" Q ""
Q $O(^ICPT("BA",COD,""))
;
EDLOAD(RETURN,DA,GMPROV,GMPVAMC) ; 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
Q
;
EDSAVE(RETURN,GMPIFN,GMPROV,GMPVAMC,UT,EDARRAY) ; SAVE EDITED RES
; RETURN - boolean, 1 success, 0 failure
; EDARRAY - array used for indirect sets of GMPORIG() and GMPFLDS()
;
N GMPFLD,GMPORIG,S,GMPLUSER
S RETURN=1 ; initialize for success
I UT S GMPLUSER=1
;
;S GMPLUSER=1
S S=""
F S S=$O(EDARRAY(S)) Q:S="" D
. S @EDARRAY(S)
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 ; last 2 vars created in nested call
S S=""
F S S=$O(UPDARRAY(S)) Q:S="" D
. S @UPDARRAY(S)
D UPDATE^GMPLUTL(.ORARRAY,.ORRETURN)
K ORARRAY
; 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) ; SAVE NEW RECORD
; RETURN - Problem IFN if success, 0 otherwise
; ADDARRAY - array used for indirect sets of GMPFLDS()
;
N DA,GMPFLD,GMPORIG,S
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
. S @ADDARRAY(S)
;
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
S GMPLUSER=$$CLINUSER(DUZ)
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(DUZ) ; 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(DUZ) ; 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?
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
ORQQPL1 ; ALB/PDR/REV - PROBLEM LIST FOR CPRS GUI ; 02/12/08
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,148,173,203,206,249,243**;Dec 17, 1997;Build 242
+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
+2 IF '+$GET(ORDATE)
SET ORDATE=DT
+3 IF '$GET(N)
SET N=100
+4 IF '$LENGTH($GET(VIEW))
SET VIEW="PL1"
+5 DO CONFIG^LEXSET("GMPL",VIEW,ORDATE)
+6 DO LOOK^LEXA(FROM,"GMPL",N,"",ORDATE)
+7 SET S=0
+8 FOR
SET S=$ORDER(LEX("LIST",S))
IF S<1
QUIT
Begin DoDot:1
+9 SET VAL1=LEX("LIST",S)
+10 SET COD=""
SET CIEN=""
SET SYS=""
SET NAME=""
+11 IF $LENGTH(VAL1,"CPT-4 ")>1
Begin DoDot:2
+12 SET SYS="ICD-9-CM "
+13 SET COD="799.9"
+14 SET CIEN=""
+15 SET NAME=$PIECE(VAL1," (CPT-4")
End DoDot:2
+16 IF $LENGTH(VAL1,"DSM-IV ")>1
Begin DoDot:2
+17 SET SYS="DSM-IV "
+18 SET COD=$PIECE($PIECE(VAL1,SYS,2),")")
+19 IF COD["/"
SET COD=$PIECE(COD,"/",1)
+20 SET CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($PIECE(VAL1,U,1),ORDATE),80)
+21 SET NAME=$PIECE(VAL1," (DSM-IV")
+22 ;
End DoDot:2
+23 IF $LENGTH(VAL1,"(TITLE 38 ")>1
Begin DoDot:2
+24 SET SYS="TITLE 38 "
+25 SET COD=$PIECE($PIECE(VAL1,SYS,2),")")
+26 IF COD["/"
SET COD=$PIECE(COD,"/",1)
+27 SET CIEN=$$CODEN^ICDCODE($$ICDONE^LEXU($PIECE(VAL1,U,1),ORDATE),80)
+28 SET NAME=$PIECE(VAL1,"(TITLE 38 ")
+29 ;
End DoDot:2
+30 IF $LENGTH(VAL1,"ICD-9-CM ")>1
Begin DoDot:2
+31 SET SYS="ICD-9-CM "
+32 SET COD=$PIECE($PIECE(VAL1,SYS,2),")")
+33 IF COD["/"
SET COD=$PIECE(COD,"/",1)
+34 SET CIEN=+$$CODEN^ICDCODE(COD,80)
+35 SET NAME=$PIECE(VAL1," (ICD-9-CM")
End DoDot:2
+36 IF $LENGTH(NAME)=0
SET NAME=$PIECE($PIECE(VAL1," (")," *")
+37 ;
+38 ; jeh Clean left over codes
+39 SET NAME=$PIECE(NAME," (CPT-4")
+40 SET NAME=$PIECE(NAME," (DSM-IV")
+41 SET NAME=$PIECE(NAME,"(TITLE 38 ")
+42 SET NAME=$PIECE(NAME," (ICD-9-CM")
+43 ;
+44 ; ien^.01^icd^icdifn^system
SET VAL=NAME_U_COD_U_CIEN_U_SYS
+45 SET LIST(S)=VAL
+46 SET MAX=S
End DoDot:1
+47 IF $GET(MAX)'=""
SET LIST(MAX+1)=$GET(LEX("MAT"))
+48 KILL ^TMP("LEXSCH",$JOB)
+49 QUIT
+50 ;
ICDREC(COD) ;
+1 NEW CODIEN
+2 IF COD=""
QUIT ""
+3 SET COD=$PIECE($PIECE(COD,U),"/")
+4 SET CODIEN=+$ORDER(^ICD9("AB",COD_" ",0))
+5 IF CODIEN'>0
SET CODIEN=+$ORDER(^ICD9("AB",COD_"0 ",0))
+6 QUIT CODIEN
+7 ;Q $O(^ICD9("BA",COD,""))
+8 ;
CPTREC(COD) ;
+1 IF COD=""
QUIT ""
+2 QUIT $ORDER(^ICPT("BA",COD,""))
+3 ;
EDLOAD(RETURN,DA,GMPROV,GMPVAMC) ; 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 QUIT
+15 ;
EDSAVE(RETURN,GMPIFN,GMPROV,GMPVAMC,UT,EDARRAY) ; 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 ; initialize for success
SET RETURN=1
+6 IF UT
SET GMPLUSER=1
+7 ;
+8 ;S GMPLUSER=1
+9 SET S=""
+10 FOR
SET S=$ORDER(EDARRAY(S))
IF S=""
QUIT
Begin DoDot:1
+11 SET @EDARRAY(S)
End DoDot:1
+12 ; Bail Out if no lock
IF $DATA(GMPFLD(10,"NEW"))>9
Begin DoDot:1
+13 ; given bogus nature of this lock, should be able to get
LOCK +^AUPNPROB(GMPIFN,11):10
+14 IF '$TEST
SET RETURN=0
End DoDot:1
IF 'RETURN
QUIT
+15 ;
+16 ; save the data
DO EN^GMPLSAVE
+17 KILL GMPFLD,GMPORIG
+18 ;
+19 ; free this instance of lock (in case it was set)
LOCK -^AUPNPROB(GMPIFN,11)
+20 SET RETURN=1
+21 QUIT
+22 ;
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
+6 SET S=""
+7 FOR
SET S=$ORDER(UPDARRAY(S))
IF S=""
QUIT
Begin DoDot:1
+8 SET @UPDARRAY(S)
End DoDot:1
+9 DO UPDATE^GMPLUTL(.ORARRAY,.ORRETURN)
+10 KILL ORARRAY
+11 ; broker wont pick up root node RETURN
+12 ; error text
SET ORRETURN(1)=ORRETURN(0)
+13 ; gmpdfn
SET ORRETURN(0)=ORRETURN
+14 ; insurance ? need
IF ORRETURN(0)=""
SET ORRETURN=1
+15 QUIT
+16 ;
ADDSAVE(RETURN,GMPDFN,GMPROV,GMPVAMC,ADDARRAY) ; 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 ;
SET RETURN=0
+6 LOCK +^AUPNPROB(0):10
+7 ; bail out if no lock
IF '$TEST
QUIT
+8 ;
+9 SET S=""
+10 FOR
SET S=$ORDER(ADDARRAY(S))
IF S=""
QUIT
Begin DoDot:1
+11 SET @ADDARRAY(S)
End DoDot:1
+12 ;
+13 DO NEW^GMPLSAVE
+14 ;
+15 SET RETURN=DA
+16 ;
+17 LOCK -^AUPNPROB(0)
+18 SET RETURN=1
+19 QUIT
+20 ;
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
+5 SET GMPLUSER=$$CLINUSER(DUZ)
+6 SET CTXT=$$GET^XPAR("ALL","ORCH CONTEXT PROBLEMS",1)
+7 ; IN1+6^GMPLMGR
SET X=$GET(^GMPL(125.99,1,0))
+8 ; problem list user, or other user
SET RETURN(0)=GMPLUSER
+9 ; GMPLVIEW("VIEW") - users default view
SET RETURN(1)=$$VIEW^GMPLX1(DUZ)
+10 ; verify transcribed problems
SET RETURN(2)=+$PIECE(X,U,2)
+11 ; prompt for chart copy
SET RETURN(3)=+$PIECE(X,U,3)
+12 ; use lexicon
SET RETURN(4)=+$PIECE(X,U,4)
+13 ; chron or reverse chron listing
SET RETURN(5)=$SELECT($PIECE(X,U,5)="R":1,1:0)
+14 SET RETURN(6)=$SELECT($PIECE($GET(CTXT),";",3)'="":$PIECE($GET(CTXT),";",3),1:"A")
+15 SET GMPLPROV=$PIECE($GET(CTXT),";",5)
+16 IF +GMPLPROV>0
IF $DATA(^VA(200,GMPLPROV))
Begin DoDot:1
+17 SET RETURN(7)=GMPLPROV_U_$PIECE(^VA(200,GMPLPROV,0),U)
End DoDot:1
+18 IF '$TEST
SET RETURN(7)="0^All"
+19 ; user's service/section
SET RETURN(8)=$$SERVICE^GMPLX1(DUZ)
+20 ; Guessing from what I see in the data that $$VIEW^GMPLX1 actually returns a composite
+21 ; of default view (in/out patient)/(c1/c2... if out patient i.e. GMPLVIEW("CLIN")) or
+22 ; /(s1/s2... if in patient i.e. GMPLVIEW("SERV"))
+23 ; Going with this assumption for now:
+24 IF $LENGTH(RETURN(1),"/")>1
Begin DoDot:1
+25 SET PV=RETURN(1)
+26 SET RETURN(1)=$PIECE(PV,"/")
+27 IF RETURN(1)="C"
SET GMPLVIEW("CLIN")=$PIECE(PV,"/",2,99)
+28 IF RETURN(1)="S"
SET GMPLVIEW("SERV")=$PIECE(PV,"/",2,99)
End DoDot:1
+29 ; ??? Where from - see tech doc
SET RETURN(9)=$GET(GMPLVIEW("SERV"))
+30 ; ??? Where from - see tech doc
SET RETURN(10)=$GET(GMPLVIEW("CLIN"))
+31 SET RETURN(11)=""
+32 ; should comments display?
SET RETURN(12)=+$PIECE($GET(CTXT),";",4)
+33 KILL GMPLVIEW
+34 QUIT
+35 ;
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
