DGRRLU0 ;alb/GAH - DG Replacement and Rehosting RPC for VADPT ;10/10/05 09:53
;;5.3;Registration;**538,725,1015**;Aug 13, 1993;Build 21
;
SET X="You Can't Enter DGRRLU0 at top of routine!"
QUIT
;
BYFILTER(FILTER,FILTERV,BDATE,EDATE,SEARCH,VALUE,DELIM) ; -- search type by clinic, provider, or ward.
NEW PCNT,OKAY,VAL
K ^TMP("DGPTLKUP",$J)
SET (OKAY,PCNT)=0
;
DO ADD^DGRRUTL("<record count='0'>")
SET LINENO=DGRRLINE
FOR I=1:1 S VAL=$P(FILTERV,DELIM,I) QUIT:VAL="" DO Q:$$STOP^XOBVLIB()
. IF FILTER="WARD" DO WARDPTS(VAL) S OKAY=1 Q
. IF FILTER="CLINIC" DO CLINPTS(VAL,BDATE,EDATE) S OKAY=2 Q
. IF FILTER="PROVIDER" D PROVPTS(VAL) S OKAY=3 Q
. IF FILTER="SPECIALTY" D SPECPTS(VAL) S OKAY=4 Q
;
IF OKAY<1 DO ADD^DGRRUTL("<error message='Filter not correctly specified'></error>")
;
; -- update the record count
DO ADDPTS()
SET @DGRRESLT@(LINENO)="<record count='"_PCNT_"'>"
IF ($G(MAXSIZRE)<1) DO ADD^DGRRUTL("<maximum message=''></maximum>")
DO ADD^DGRRUTL("<error message=''></error>")
QUIT
;
FILTCHK(DFN,TYPE,VALUE) ; -- Filter search -
; -- check patients to match search type and search value for filter searches
; -- returns 1 if matches, 0 if no match
;
SET VALUE=$$UP^XLFSTR(VALUE)
Q:($G(VALUE)="")!($G(VALUE)="*") 1
Q:($G(TYPE)="") 1
Q:($G(DFN)<1) 0
;
NEW I,J,OKAY,CHKVAL
SET OKAY=0
IF TYPE="NAME" DO
. IF VALUE[", " SET VALUE=$P(VALUE,", ")_","_$P(VALUE,", ",2) ; REMOVE FIRST SPACE line added sgg 070104
. SET CHKVAL=$P($G(^DPT(DFN,0)),"^",1)
. IF $E(CHKVAL,1,$LENGTH(VALUE))=VALUE SET OKAY=1
IF TYPE="SSN" DO
. SET CHKVAL=$P($G(^DPT(DFN,0)),"^",9)
. SET VALUE=$TR(VALUE," -","") ; REMOVE DASHES AND SPACES line added sgg 070104
. IF $E(CHKVAL,1,$LENGTH(VALUE))=VALUE SET OKAY=1
IF TYPE="ICN" DO
. ;SET CHKVAL=$P($G(^DPT(DFN,"MPI")),"^",1)
. S CHKVAL=+$$GETICN^MPIF001(DFN)
. IF $E(CHKVAL,1,$LENGTH(VALUE))=VALUE SET OKAY=1
IF TYPE="SSN4" DO
. SET CHKVAL=$E($P($G(^DPT(DFN,0)),"^",1),1)_$E($P($G(^DPT(DFN,0)),"^",9),6,9)
. IF $E(CHKVAL,1,$LENGTH(VALUE))=VALUE SET OKAY=1
QUIT OKAY
;
WARDPTS(WARD) ; RETURN LIST OF PATIENTS IN A WARD
; Based on ORQPTQ2
Q:+$G(WARD)<1
N DFN
S DFN=0
S WARD=$P(^DIC(42,WARD,0),"^") ;GET WARD NAME FOR "CN" LOOKUP
Q:WARD=""
F D Q:DFN'>0 Q:$$STOP^XOBVLIB()
. S DFN=$O(^DPT("CN",WARD,DFN)) Q:DFN'>0
. Q:'$$FILTCHK(DFN,SEARCH,VALUE)
. S ^TMP("DGPTLKUP",$J,$P($G(^DPT(DFN,0)),"^",1),DFN)=""
Q
;
PROVPTS(PROV) ; RETURN LIST OF PATIENTS LINKED TO A PRIMARY PROVIDER
; Based on ORQPTQ2
; "APR" xref is on field PROVIDER in file 2 (2;.104)
; "AAP" xref is on field ATTENDING PHYSICIAN in file 2 (2;.1041)
;
Q:+$G(PROV)<1
;
N DFN,XREF
S DFN=0
F XREF="AAP","APR" DO
. F S DFN=$O(^DPT(XREF,PROV,DFN)) Q:DFN'>0 D Q:$$STOP^XOBVLIB()
.. Q:'$$FILTCHK(DFN,SEARCH,VALUE)
.. S ^TMP("DGPTLKUP",$J,$P($G(^DPT(DFN,0)),"^",1),DFN)=""
Q
;
CLINPTS(CLIN,BDATE,EDATE) ; RETURN LIST OF PTS W/CLINIC APPT W/IN BEGINNING AND END DATES
Q:+$G(CLIN)<1
;
N DFN,NAME,I,J,X,Y,ORJ,ORSRV,ORNOWDT,CHKX,CHKIN,MAXAPPTS,ORC,CLNAM,NOWDT
S MAXAPPTS=200
S NOWDT=$$NOW^XLFDT
;
S DFN=0,I=1
IF $G(BDATE)="" S BDATE="T"
IF $G(EDATE)="" S EDATE="T+1"
;CONVERT BDATE AND EDATE INTO FILEMAN DATE/TIME
D DT^DILF("T",BDATE,.BDATE,"","")
D DT^DILF("T",EDATE,.EDATE,"","")
I (BDATE=-1)!(EDATE=-1) S Y(1)="^Error in date range." Q
S EDATE=$P(EDATE,".")_.5 ;ADD 1/2 DAY TO END DATE
;
D CLINPT2(+CLIN,BDATE,EDATE)
QUIT
;
CLINPT2(CLIN,BEGIN,END) ; -- Use scheduling rehosting API from patches SD*5.3*253 and SD*5.3*275
; -- GETPLIST^SDAMA202(SDIEN,SDFIELDS,SDAPSTAT,SDSTART,SDEND,.SDRESULT,SDIOSTAT)
;
K ^TMP($J,"SDAMA202","GETPLIST")
NEW I,X,APPTS,APPTDT SET APPTS=""
;
; -- get appointment date/time, patient status, patient ien & name,
; only get appointment status = "R" for scheduled or kept appointments.
DO GETPLIST^SDAMA202(+CLIN,"1;3;4","R",BEGIN,END,.APPTS)
;
; -- check number of appointments
I APPTS<1 K ^TMP($J,"SDAMA202","GETPLIST") Q
;
; -- check for an error, may need to pass message up.
I $D(^TMP($J,"SDAMA202","GETPTLIST","ERROR")) QUIT
;
; -- move list of appointments to list of patients, ordered by name, dfn
S (I,X)=""
F SET I=$O(^TMP($J,"SDAMA202","GETPLIST",I)) Q:I<1 S X=^(I,4) DO
. Q:'$$FILTCHK(+X,SEARCH,VALUE) ;check if meets search criteria
. S APPTDT=$G(^TMP($J,"SDAMA202","GETPLIST",I,1))
. S ^TMP("DGPTLKUP",$J,$P(X,"^",2),+X,+APPTDT)=""
K ^TMP($J,"SDAMA202","GETPLIST")
QUIT
;
SPECPTS(SPEC) ;Returns a list of patients associated with a specialty
; "ATR" cross reference is on the Treating Specialty (#.103) field
; in the Patient (#2) file and is a pointer to the Facility
; Treating Specialty (#45.7) file.
;
Q:+$G(SPEC)<1
N DFN
S DFN=0
F S DFN=$O(^DPT("ATR",+SPEC,DFN)) Q:DFN'>0 D Q:$$STOP^XOBVLIB()
.Q:'$$FILTCHK(DFN,SEARCH,VALUE)
.S ^TMP("DGPTLKUP",$J,$P($G(^DPT(DFN,0)),U),DFN)=""
Q
;
ADDPTS() ;
N NAME,DFN,DGRRFLG,DGRRAPTS,DGRRCTR
S NAME=""
S (DGRRFLG,DGRRCTR)=0
S DGRRAPTS=$S(FILTER="CLINIC":1,1:0)
FOR SET NAME=$O(^TMP("DGPTLKUP",$J,NAME)) Q:NAME=""!(DGRRFLG=1) DO
. S DFN="" FOR SET DFN=$O(^TMP("DGPTLKUP",$J,NAME,DFN)) Q:DFN<1!(DGRRFLG=1) DO
.. S DGRRCTR=DGRRCTR+1
.. I DGRRCTR>MAXSIZE S DGRRFLG=1 Q
.. DO PTDATA^DGRRLUA(DFN,.PCNT)
.. I FILTER'="CLINIC" Q
.. D ADD^DGRRUTL("<appointments>")
.. N APPTDT
.. S APPTDT=""
.. F S APPTDT=$O(^TMP("DGPTLKUP",$J,NAME,DFN,APPTDT)) Q:'APPTDT D
...D ADD^DGRRUTL("<appointmentTime>"_APPTDT_"</appointmentTime>")
.. D ADD^DGRRUTL("</appointments>")
.. D ADD^DGRRUTL("</patient>")
I DGRRCTR>MAXSIZE D
.IF $G(MAXSIZRE)<1 DO ADD^DGRRLU("<maximum message='Too many patients found (more than "_MAXSIZE_"). Please Limit Search.'></maximum>")
.SET MAXSIZRE=1
K ^TMP("DGPTLKUP",$J)
;IF ($G(MAXSIZRE)<1) DO ADD^DGRRUTL("<maximum message=''></maximum>")
Q
;
NAMECOMP(DFN,DGRRCNT) ; ENTRY IS +$P($G(^DPT(DFN,"NAME")),"^",1)
;
N LN,FN,MI,PR,SU,DE,DGA,DGNMC
S DGA=+$P($G(^DPT(DFN,"NAME")),U)_","
D GETS^DIQ(20,+DGA,"1:6","","DGNMC")
S LN=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,1)))
S FN=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,2)))
S MI=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,3)))
S PR=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,4)))
S SU=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,5)))
S DE=$$CHARCHK^DGRRUTL($G(DGNMC(20,DGA,6)))
DO ADD^DGRRUTL("<namecomp number='"_DGRRCNT_"' last='"_LN_"' first='"_FN_"' middle='"_MI_"' prefix='"_PR_"' suffix='"_SU_"' degree='"_DE_"' ></namecomp>")
;
DGRRLU0 ;alb/GAH - DG Replacement and Rehosting RPC for VADPT ;10/10/05 09:53
+1 ;;5.3;Registration;**538,725,1015**;Aug 13, 1993;Build 21
+2 ;
+3 SET X="You Can't Enter DGRRLU0 at top of routine!"
+4 QUIT
+5 ;
BYFILTER(FILTER,FILTERV,BDATE,EDATE,SEARCH,VALUE,DELIM) ; -- search type by clinic, provider, or ward.
+1 NEW PCNT,OKAY,VAL
+2 KILL ^TMP("DGPTLKUP",$JOB)
+3 SET (OKAY,PCNT)=0
+4 ;
+5 DO ADD^DGRRUTL("<record count='0'>")
+6 SET LINENO=DGRRLINE
+7 FOR I=1:1
SET VAL=$PIECE(FILTERV,DELIM,I)
IF VAL=""
QUIT
Begin DoDot:1
+8 IF FILTER="WARD"
DO WARDPTS(VAL)
SET OKAY=1
QUIT
+9 IF FILTER="CLINIC"
DO CLINPTS(VAL,BDATE,EDATE)
SET OKAY=2
QUIT
+10 IF FILTER="PROVIDER"
DO PROVPTS(VAL)
SET OKAY=3
QUIT
+11 IF FILTER="SPECIALTY"
DO SPECPTS(VAL)
SET OKAY=4
QUIT
End DoDot:1
IF $$STOP^XOBVLIB()
QUIT
+12 ;
+13 IF OKAY<1
DO ADD^DGRRUTL("<error message='Filter not correctly specified'></error>")
+14 ;
+15 ; -- update the record count
+16 DO ADDPTS()
+17 SET @DGRRESLT@(LINENO)="<record count='"_PCNT_"'>"
+18 IF ($GET(MAXSIZRE)<1)
DO ADD^DGRRUTL("<maximum message=''></maximum>")
+19 DO ADD^DGRRUTL("<error message=''></error>")
+20 QUIT
+21 ;
FILTCHK(DFN,TYPE,VALUE) ; -- Filter search -
+1 ; -- check patients to match search type and search value for filter searches
+2 ; -- returns 1 if matches, 0 if no match
+3 ;
+4 SET VALUE=$$UP^XLFSTR(VALUE)
+5 IF ($GET(VALUE)="")!($GET(VALUE)="*")
QUIT 1
+6 IF ($GET(TYPE)="")
QUIT 1
+7 IF ($GET(DFN)<1)
QUIT 0
+8 ;
+9 NEW I,J,OKAY,CHKVAL
+10 SET OKAY=0
+11 IF TYPE="NAME"
Begin DoDot:1
+12 ; REMOVE FIRST SPACE line added sgg 070104
IF VALUE[", "
SET VALUE=$PIECE(VALUE,", ")_","_$PIECE(VALUE,", ",2)
+13 SET CHKVAL=$PIECE($GET(^DPT(DFN,0)),"^",1)
+14 IF $EXTRACT(CHKVAL,1,$LENGTH(VALUE))=VALUE
SET OKAY=1
End DoDot:1
+15 IF TYPE="SSN"
Begin DoDot:1
+16 SET CHKVAL=$PIECE($GET(^DPT(DFN,0)),"^",9)
+17 ; REMOVE DASHES AND SPACES line added sgg 070104
SET VALUE=$TRANSLATE(VALUE," -","")
+18 IF $EXTRACT(CHKVAL,1,$LENGTH(VALUE))=VALUE
SET OKAY=1
End DoDot:1
+19 IF TYPE="ICN"
Begin DoDot:1
+20 ;SET CHKVAL=$P($G(^DPT(DFN,"MPI")),"^",1)
+21 SET CHKVAL=+$$GETICN^MPIF001(DFN)
+22 IF $EXTRACT(CHKVAL,1,$LENGTH(VALUE))=VALUE
SET OKAY=1
End DoDot:1
+23 IF TYPE="SSN4"
Begin DoDot:1
+24 SET CHKVAL=$EXTRACT($PIECE($GET(^DPT(DFN,0)),"^",1),1)_$EXTRACT($PIECE($GET(^DPT(DFN,0)),"^",9),6,9)
+25 IF $EXTRACT(CHKVAL,1,$LENGTH(VALUE))=VALUE
SET OKAY=1
End DoDot:1
+26 QUIT OKAY
+27 ;
WARDPTS(WARD) ; RETURN LIST OF PATIENTS IN A WARD
+1 ; Based on ORQPTQ2
+2 IF +$GET(WARD)<1
QUIT
+3 NEW DFN
+4 SET DFN=0
+5 ;GET WARD NAME FOR "CN" LOOKUP
SET WARD=$PIECE(^DIC(42,WARD,0),"^")
+6 IF WARD=""
QUIT
+7 FOR
Begin DoDot:1
+8 SET DFN=$ORDER(^DPT("CN",WARD,DFN))
IF DFN'>0
QUIT
+9 IF '$$FILTCHK(DFN,SEARCH,VALUE)
QUIT
+10 SET ^TMP("DGPTLKUP",$JOB,$PIECE($GET(^DPT(DFN,0)),"^",1),DFN)=""
End DoDot:1
IF DFN'>0
QUIT
IF $$STOP^XOBVLIB()
QUIT
+11 QUIT
+12 ;
PROVPTS(PROV) ; RETURN LIST OF PATIENTS LINKED TO A PRIMARY PROVIDER
+1 ; Based on ORQPTQ2
+2 ; "APR" xref is on field PROVIDER in file 2 (2;.104)
+3 ; "AAP" xref is on field ATTENDING PHYSICIAN in file 2 (2;.1041)
+4 ;
+5 IF +$GET(PROV)<1
QUIT
+6 ;
+7 NEW DFN,XREF
+8 SET DFN=0
+9 FOR XREF="AAP","APR"
Begin DoDot:1
+10 FOR
SET DFN=$ORDER(^DPT(XREF,PROV,DFN))
IF DFN'>0
QUIT
Begin DoDot:2
+11 IF '$$FILTCHK(DFN,SEARCH,VALUE)
QUIT
+12 SET ^TMP("DGPTLKUP",$JOB,$PIECE($GET(^DPT(DFN,0)),"^",1),DFN)=""
End DoDot:2
IF $$STOP^XOBVLIB()
QUIT
End DoDot:1
+13 QUIT
+14 ;
CLINPTS(CLIN,BDATE,EDATE) ; RETURN LIST OF PTS W/CLINIC APPT W/IN BEGINNING AND END DATES
+1 IF +$GET(CLIN)<1
QUIT
+2 ;
+3 NEW DFN,NAME,I,J,X,Y,ORJ,ORSRV,ORNOWDT,CHKX,CHKIN,MAXAPPTS,ORC,CLNAM,NOWDT
+4 SET MAXAPPTS=200
+5 SET NOWDT=$$NOW^XLFDT
+6 ;
+7 SET DFN=0
SET I=1
+8 IF $GET(BDATE)=""
SET BDATE="T"
+9 IF $GET(EDATE)=""
SET EDATE="T+1"
+10 ;CONVERT BDATE AND EDATE INTO FILEMAN DATE/TIME
+11 DO DT^DILF("T",BDATE,.BDATE,"","")
+12 DO DT^DILF("T",EDATE,.EDATE,"","")
+13 IF (BDATE=-1)!(EDATE=-1)
SET Y(1)="^Error in date range."
QUIT
+14 ;ADD 1/2 DAY TO END DATE
SET EDATE=$PIECE(EDATE,".")_.5
+15 ;
+16 DO CLINPT2(+CLIN,BDATE,EDATE)
+17 QUIT
+18 ;
CLINPT2(CLIN,BEGIN,END) ; -- Use scheduling rehosting API from patches SD*5.3*253 and SD*5.3*275
+1 ; -- GETPLIST^SDAMA202(SDIEN,SDFIELDS,SDAPSTAT,SDSTART,SDEND,.SDRESULT,SDIOSTAT)
+2 ;
+3 KILL ^TMP($JOB,"SDAMA202","GETPLIST")
+4 NEW I,X,APPTS,APPTDT
SET APPTS=""
+5 ;
+6 ; -- get appointment date/time, patient status, patient ien & name,
+7 ; only get appointment status = "R" for scheduled or kept appointments.
+8 DO GETPLIST^SDAMA202(+CLIN,"1;3;4","R",BEGIN,END,.APPTS)
+9 ;
+10 ; -- check number of appointments
+11 IF APPTS<1
KILL ^TMP($JOB,"SDAMA202","GETPLIST")
QUIT
+12 ;
+13 ; -- check for an error, may need to pass message up.
+14 IF $DATA(^TMP($JOB,"SDAMA202","GETPTLIST","ERROR"))
QUIT
+15 ;
+16 ; -- move list of appointments to list of patients, ordered by name, dfn
+17 SET (I,X)=""
+18 FOR
SET I=$ORDER(^TMP($JOB,"SDAMA202","GETPLIST",I))
IF I<1
QUIT
SET X=^(I,4)
Begin DoDot:1
+19 ;check if meets search criteria
IF '$$FILTCHK(+X,SEARCH,VALUE)
QUIT
+20 SET APPTDT=$GET(^TMP($JOB,"SDAMA202","GETPLIST",I,1))
+21 SET ^TMP("DGPTLKUP",$JOB,$PIECE(X,"^",2),+X,+APPTDT)=""
End DoDot:1
+22 KILL ^TMP($JOB,"SDAMA202","GETPLIST")
+23 QUIT
+24 ;
SPECPTS(SPEC) ;Returns a list of patients associated with a specialty
+1 ; "ATR" cross reference is on the Treating Specialty (#.103) field
+2 ; in the Patient (#2) file and is a pointer to the Facility
+3 ; Treating Specialty (#45.7) file.
+4 ;
+5 IF +$GET(SPEC)<1
QUIT
+6 NEW DFN
+7 SET DFN=0
+8 FOR
SET DFN=$ORDER(^DPT("ATR",+SPEC,DFN))
IF DFN'>0
QUIT
Begin DoDot:1
+9 IF '$$FILTCHK(DFN,SEARCH,VALUE)
QUIT
+10 SET ^TMP("DGPTLKUP",$JOB,$PIECE($GET(^DPT(DFN,0)),U),DFN)=""
End DoDot:1
IF $$STOP^XOBVLIB()
QUIT
+11 QUIT
+12 ;
ADDPTS() ;
+1 NEW NAME,DFN,DGRRFLG,DGRRAPTS,DGRRCTR
+2 SET NAME=""
+3 SET (DGRRFLG,DGRRCTR)=0
+4 SET DGRRAPTS=$SELECT(FILTER="CLINIC":1,1:0)
+5 FOR
SET NAME=$ORDER(^TMP("DGPTLKUP",$JOB,NAME))
IF NAME=""!(DGRRFLG=1)
QUIT
Begin DoDot:1
+6 SET DFN=""
FOR
SET DFN=$ORDER(^TMP("DGPTLKUP",$JOB,NAME,DFN))
IF DFN<1!(DGRRFLG=1)
QUIT
Begin DoDot:2
+7 SET DGRRCTR=DGRRCTR+1
+8 IF DGRRCTR>MAXSIZE
SET DGRRFLG=1
QUIT
+9 DO PTDATA^DGRRLUA(DFN,.PCNT)
+10 IF FILTER'="CLINIC"
QUIT
+11 DO ADD^DGRRUTL("<appointments>")
+12 NEW APPTDT
+13 SET APPTDT=""
+14 FOR
SET APPTDT=$ORDER(^TMP("DGPTLKUP",$JOB,NAME,DFN,APPTDT))
IF 'APPTDT
QUIT
Begin DoDot:3
+15 DO ADD^DGRRUTL("<appointmentTime>"_APPTDT_"</appointmentTime>")
End DoDot:3
+16 DO ADD^DGRRUTL("</appointments>")
+17 DO ADD^DGRRUTL("</patient>")
End DoDot:2
End DoDot:1
+18 IF DGRRCTR>MAXSIZE
Begin DoDot:1
+19 IF $GET(MAXSIZRE)<1
DO ADD^DGRRLU("<maximum message='Too many patients found (more than "_MAXSIZE_"). Please Limit Search.'></maximum>")
+20 SET MAXSIZRE=1
End DoDot:1
+21 KILL ^TMP("DGPTLKUP",$JOB)
+22 ;IF ($G(MAXSIZRE)<1) DO ADD^DGRRUTL("<maximum message=''></maximum>")
+23 QUIT
+24 ;
NAMECOMP(DFN,DGRRCNT) ; ENTRY IS +$P($G(^DPT(DFN,"NAME")),"^",1)
+1 ;
+2 NEW LN,FN,MI,PR,SU,DE,DGA,DGNMC
+3 SET DGA=+$PIECE($GET(^DPT(DFN,"NAME")),U)_","
+4 DO GETS^DIQ(20,+DGA,"1:6","","DGNMC")
+5 SET LN=$$CHARCHK^DGRRUTL($GET(DGNMC(20,DGA,1)))
+6 SET FN=$$CHARCHK^DGRRUTL($GET(DGNMC(20,DGA,2)))
+7 SET MI=$$CHARCHK^DGRRUTL($GET(DGNMC(20,DGA,3)))
+8 SET PR=$$CHARCHK^DGRRUTL($GET(DGNMC(20,DGA,4)))
+9 SET SU=$$CHARCHK^DGRRUTL($GET(DGNMC(20,DGA,5)))
+10 SET DE=$$CHARCHK^DGRRUTL($GET(DGNMC(20,DGA,6)))
+11 DO ADD^DGRRUTL("<namecomp number='"_DGRRCNT_"' last='"_LN_"' first='"_FN_"' middle='"_MI_"' prefix='"_PR_"' suffix='"_SU_"' degree='"_DE_"' ></namecomp>")
+12 ;
