PXRRFDSE ;ISL/PKR - Sort through encounters applying the selection criteria. ;3/11/98
;;1.0;PCE PATIENT CARE ENCOUNTER;**3,10,12,31,49**;Aug 12, 1996
SORT ;
N BD,BUSY,CLASSIEN,CLASSNAM,CLINIC,CLINIEN,CSSCR,DOB,DFN,ED
N IC,FAC,FACILITY,FOUND
N HLOC,HLOCIEN,HLOCNAM,HSSCR,NEWPIEN
N PATSCR,PCLASS,PNAME,PPONLY,PRVIEN,PRVALL,PRVSCR
N RACEUNK,TEMP,VIEN,VISIT
;
;Allow the task to be cleaned up upon successful completion.
S ZTREQ="@"
;
I '(PXRRQUE!$D(IO("S"))) D INIT^PXRRBUSY(.BUSY)
;
;CSSCR is true if we want selected clinics.
I $G(NCS)>0 S CSSCR=1
E S CSSCR=0,CLINIC=0
;
;CLINIC is true if we want clinics instead of hospital locations.
I $P($G(PXRRLCSC),U,1)["C" S CLINIC=1
E S CLINIC=0
;
;HSSCR is true if we want selected hospital locations.
I $P($G(PXRRLCSC),U,1)="HS" S HSSCR=1
E S HSSCR=0
;
;HLOC is true if we want hospital locations.
I $P($G(PXRRLCSC),U,1)["H" S HLOC=1
E S HLOC=0
;
;PATSCR is true if we have a patient screen.
S PATSCR=0
I $D(PXRRDOB) D
. S PATSCR=1
.;If the starting or ending date of birth is not defined at this point
.;then we should not screen for them. So set them to values that will
.;always be true. Remember the test is DOBS <= DOB <= DOBE so that
.;DOBS corresponds to the maximum age and DOBE to the minimum age.
. I '$D(PXRRDOBS) S PXRRDOBS=0
. I '$D(PXRRDOBE) S PXRRDOBE=DT
I $D(PXRRRACE) D
. S PATSCR=1
.;Find the "UNKNOWN" race entry.
. N TRACE,TERR
. D FIND^DIC(10,"","","O","UNKNOWN",1,"B","","","TRACE","TERR")
. S RACEUNK=TRACE("DILIST",2,1)_U_TRACE("DILIST",1,1)
I $D(PXRRSEX) S PATSCR=1
;
;PRVSCR is true if we have a provider screen
I $D(PXRRPRSC) S PRVSCR=1
E S CLASSNAM=0,PRVSCR=0,PNAME=1
;
;If they are asking for all providers then we don't really need to
; screen.
;I PRVSCR I $P(PXRRPRSC,U,1)="A" S CLASSNAM=0,PRVSCR=0,PNAME=1
;See if all providers were requested.
I PRVSCR I $P(PXRRPRSC,U,1)="A" S PRVALL=1
E S PRVALL=0
;
;PPONLY is true if we want primary providers only.
I PRVSCR I $P(PXRRPRSC,U,1)="P" S PPONLY=1
E S PPONLY=0
;
;Allow the task to be cleaned up upon successful completion.
S ZTREQ="@"
;
S BD=PXRRBDT-.0001
S ED=PXRREDT+.2359
NDATE S BD=$O(^AUPNVSIT("B",BD))
;If we have passed the ending date we are done.
I (BD>ED)!(BD="") G DONE
;
;Check for a user request to stop the task.
I $$S^%ZTLOAD S ZTSTOP=1 D EXIT^PXRRFDD
;
;Get the VISIT IEN
S VIEN=0
VISIT S VIEN=$O(^AUPNVSIT("B",BD,VIEN))
I VIEN="" G NDATE
S VISIT=^AUPNVSIT(VIEN,0)
;
;If this is an interactive session let the user know that something
;is happening.
I '(PXRRQUE!$D(IO("S"))) D SPIN^PXRRBUSY("Sorting encounters",.BUSY)
;
;Service category screen.
I $D(PXRRSCAT) I PXRRSCAT'[$P(VISIT,U,7) G VISIT
;
;Encounter type screen.
I $D(PXRRETYP) I PXRRETYP'[$P(VISIT,U,3) G VISIT
;
;Patient screen. If we have a patient screen then we need to make a
;VADPT call to get the patient information.
I PATSCR D
. S DFN=$P(VISIT,U,5)
. D KVAR^VADPT
. D DEM^VADPT
;
S FOUND=1
;
;Patient DOB screen.
I $D(PXRRDOB) D
. S DOB=$P(VADM(3),U,1)
. I (DOB<PXRRDOBS)!(DOB>PXRRDOBE) S FOUND=0
I 'FOUND G VISIT
;
;Patient RACE screen.
I $D(PXRRRACE) D
. S FOUND=0
. I VADM(8)="" S VADM(8)=RACEUNK
. F IC=1:1:NRACE Q:FOUND D
.. I PXRRRACE(IC)=VADM(8) S FOUND=1
I 'FOUND G VISIT
;
;Patient SEX screen.
I $D(PXRRSEX) D
. I PXRRSEX'=VADM(5) S FOUND=0
I 'FOUND G VISIT
;
;Make sure that the facility is on the list.
S FOUND=0
S FAC=$P(VISIT,U,6)
F IC=1:1:NFAC I $P(PXRRFAC(IC),U,1)=FAC D Q
. S FACILITY=FAC
. S FOUND=1
I 'FOUND G VISIT
;
;Provider screen.
S PRVIEN=0
PRV ;To allow for encounters without a provider the check for a null PRVIEN
;is made after everything else has been done.
I PRVIEN="" G VISIT
I PRVSCR D
. S PRVIEN=$O(^AUPNVPRV("AD",VIEN,PRVIEN))
. I $L(PRVIEN)>0 S NEWPIEN=$P(^AUPNVPRV(PRVIEN,0),U,1)
. E S NEWPIEN=0
. S (CLASSNAM,PNAME)=1
S FOUND=1
;
;All providers by name.
I PRVALL D
. S PNAME=$P($G(^VA(200,NEWPIEN,0)),U,1)
. I $L(PNAME)=0 S PNAME=1
. E S PNAME=PNAME_U_NEWPIEN
;
;List of providers.
I $D(PXRRPRPL) D
. S FOUND=0
. F IC=1:1:NPL I $P(PXRRPRPL(IC),U,2)=NEWPIEN D Q
..;Mark this provider as being found.
.. S $P(PXRRPRPL(IC),U,4)="M"
.. S PNAME=$P(PXRRPRPL(IC),U,1,2)
.. S FOUND=1
;
;If we are storing provider names, i.e., PNAME'=1, then store the Person
;Class alpha abbreviation as the third piece of PNAME.
I PNAME'=1 D
. S PCLASS=$$OCCUP^PXBGPRV(NEWPIEN,BD,"",1)
. S TEMP=$$ALPHA^PXRRPECU(PCLASS)
. S PNAME=PNAME_U_TEMP
I 'FOUND G PRV
;
;Person class screen.
I $D(PXRRPECL) D
. S CLASSNAM=$$OCCUP^PXBGPRV(NEWPIEN,BD,"",1,"")
. S FOUND=$$MATCH^PXRRPECU(CLASSNAM)
. I FOUND S CLASSNAM=$P(CLASSNAM,U,7)
I 'FOUND G PRV
;
;Primary Provider only.
I PPONLY D
. S FOUND=0
. I PRVIEN>0 D
.. I $P(^AUPNVPRV(PRVIEN,0),U,4)="P" S FOUND=1
I 'FOUND G PRV
;
S HLOCNAM=1
;By Clinic
I CLINIC D
. S CLINIEN=$P(VISIT,U,8)
. S TEMP=$S(+CLINIEN>0:^DIC(40.7,CLINIEN,0),1:"Unknown")
. S HLOCNAM=$P(TEMP,U,1)_U_CLINIEN_U_$P(TEMP,U,2)
;Clinic screen.
I CSSCR D
. S FOUND=0
. F IC=1:1:NCS I $P(PXRRCS(IC),U,2)=CLINIEN D Q
..;Mark the clinic as being matched.
.. S $P(PXRRCS(IC),U,4)="M"
.. S FOUND=1
I 'FOUND G VISIT
;
;By hospital location.
I HLOC D
. S HLOCIEN=$P(VISIT,U,22)
. I +HLOCIEN>0 D
.. S HLOCNAM=$P(^SC(HLOCIEN,0),U,1)_U_HLOCIEN
.. S CLINIEN=$P(^SC(HLOCIEN,0),U,7)
.. S TEMP=$S(+CLINIEN>0:^DIC(40.7,CLINIEN,0),1:"")
.. S HLOCNAM=$P(^SC(HLOCIEN,0),U,1)_U_HLOCIEN_U_$P(TEMP,U,2)
. E D
..;No hospital location, see if we can at least find the clinic.
.. S HLOCNAM="Unknown"
.. S CLINIEN=$P(VISIT,U,8)
.. S TEMP=$S(+CLINIEN>0:^DIC(40.7,CLINIEN,0),1:"")
.. S HLOCNAM="Unknown"_U_U_$P(TEMP,U,2)
;Hospital location screen.
I HSSCR D
. S FOUND=0
. F IC=1:1:NHL I $P(PXRRLCHL(IC),U,2)=HLOCIEN D Q
..;Mark the hospital location as being matched.
.. S $P(PXRRLCHL(IC),U,4)="M"
.. S FOUND=1
I 'FOUND G VISIT
;
;At this point we have an encounter that can be added to the list.
S ^XTMP(PXRRXTMP,"ENCTR",FACILITY,PNAME,CLASSNAM,HLOCNAM,VIEN)=""
;
;Get the next encounter.
G VISIT
;
DONE ;
D KVAR^VADPT
I '(PXRRQUE!$D(IO("S"))) D DONE^PXRRBUSY("done")
;
;If there were selected clinic stops build dummy entries for all
;those without entries.
I $D(PXRRCS) D
. F FAC=1:1:NFAC D
.. S FACILITY=$P(PXRRFAC(FAC),U,1)
.. F IC=1:1:NCS D
... I $P(PXRRCS(IC),U,4)'="M" D
.... S PNAME=0
.... S CLASSNAM=0
.... S HLOCNAM=PXRRCS(IC)
.... S ^XTMP(PXRRXTMP,"ENCTR",FACILITY,PNAME,CLASSNAM,HLOCNAM,0)=""
;
;If there were selected hospital locations build dummy entries for all
;those without entries.
I $D(PXRRLCHL) D
. F FAC=1:1:NFAC D
.. S FACILITY=$P(PXRRFAC(FAC),U,1)
.. F IC=1:1:NHL D
... I $P(PXRRLCHL(IC),U,4)'="M" D
.... S PNAME=0
.... S CLASSNAM=0
.... S HLOCNAM=PXRRLCHL(IC)
.... S ^XTMP(PXRRXTMP,"ENCTR",FACILITY,PNAME,CLASSNAM,HLOCNAM,0)=""
;
;If there were selected providers build dummy entries for all those
;without encounters.
I $D(PXRRPRPL) D
. N CLASSLST,JC,NPCLASS
. F FAC=1:1:NFAC D
.. S FACILITY=$P(PXRRFAC(FAC),U,1)
.. F IC=1:1:NPL D
... I $P(PXRRPRPL(IC),U,4)'="M" D
.... S PNAME=$P(PXRRPRPL(IC),U,1,2)
.... S NEWPIEN=$P(PNAME,U,2)
....;Get the person class list for this provider.
.... S NPCLASS=$$PCLLIST^PXRRPECU(NEWPIEN,PXRRBDT,PXRREDT,.CLASSLST)
.... F JC=1:1:NPCLASS D
..... S TEMP=PNAME_U_CLASSLST(JC)
..... S ^XTMP(PXRRXTMP,"ENCTR",FACILITY,TEMP,0,0)=""
;
;If there were person classes build dummy entries for all those
;without entries.
I $D(PXRRPECL) D
. F FAC=1:1:NFAC D
.. S FACILITY=$P(PXRRFAC(FAC),U,1)
.. F IC=1:1:NCL D
... I $P(PXRRPECL(IC),U,4)'="M" D
.... S PNAME=0
.... S CLASSNAM=$P(PXRRPECL(IC),U,1,3)
.... S HLOCNAM=0
.... S ^XTMP(PXRRXTMP,"ENCTR",FACILITY,PNAME,CLASSNAM,HLOCNAM,0)=""
;
EXIT ;
;Run the next task in the series.
I PXRRQUE D
. N DESC,ROUTINE,TASK
. S DESC="Frequency of Diagnosis Report - sort diagnosis data"
. S ROUTINE="SORT^PXRRFDSD"
. S TASK=^XTMP(PXRRXTMP,"SORTDZTSK")
. S ZTDTH=$$NOW^XLFDT
. D REQUE^PXRRQUE(DESC,ROUTINE,TASK)
E D SORT^PXRRFDSD
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRRFDSE 8412 printed Nov 22, 2024@17:40:43 Page 2
PXRRFDSE ;ISL/PKR - Sort through encounters applying the selection criteria. ;3/11/98
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**3,10,12,31,49**;Aug 12, 1996
SORT ;
+1 NEW BD,BUSY,CLASSIEN,CLASSNAM,CLINIC,CLINIEN,CSSCR,DOB,DFN,ED
+2 NEW IC,FAC,FACILITY,FOUND
+3 NEW HLOC,HLOCIEN,HLOCNAM,HSSCR,NEWPIEN
+4 NEW PATSCR,PCLASS,PNAME,PPONLY,PRVIEN,PRVALL,PRVSCR
+5 NEW RACEUNK,TEMP,VIEN,VISIT
+6 ;
+7 ;Allow the task to be cleaned up upon successful completion.
+8 SET ZTREQ="@"
+9 ;
+10 IF '(PXRRQUE!$DATA(IO("S")))
DO INIT^PXRRBUSY(.BUSY)
+11 ;
+12 ;CSSCR is true if we want selected clinics.
+13 IF $GET(NCS)>0
SET CSSCR=1
+14 IF '$TEST
SET CSSCR=0
SET CLINIC=0
+15 ;
+16 ;CLINIC is true if we want clinics instead of hospital locations.
+17 IF $PIECE($GET(PXRRLCSC),U,1)["C"
SET CLINIC=1
+18 IF '$TEST
SET CLINIC=0
+19 ;
+20 ;HSSCR is true if we want selected hospital locations.
+21 IF $PIECE($GET(PXRRLCSC),U,1)="HS"
SET HSSCR=1
+22 IF '$TEST
SET HSSCR=0
+23 ;
+24 ;HLOC is true if we want hospital locations.
+25 IF $PIECE($GET(PXRRLCSC),U,1)["H"
SET HLOC=1
+26 IF '$TEST
SET HLOC=0
+27 ;
+28 ;PATSCR is true if we have a patient screen.
+29 SET PATSCR=0
+30 IF $DATA(PXRRDOB)
Begin DoDot:1
+31 SET PATSCR=1
+32 ;If the starting or ending date of birth is not defined at this point
+33 ;then we should not screen for them. So set them to values that will
+34 ;always be true. Remember the test is DOBS <= DOB <= DOBE so that
+35 ;DOBS corresponds to the maximum age and DOBE to the minimum age.
+36 IF '$DATA(PXRRDOBS)
SET PXRRDOBS=0
+37 IF '$DATA(PXRRDOBE)
SET PXRRDOBE=DT
End DoDot:1
+38 IF $DATA(PXRRRACE)
Begin DoDot:1
+39 SET PATSCR=1
+40 ;Find the "UNKNOWN" race entry.
+41 NEW TRACE,TERR
+42 DO FIND^DIC(10,"","","O","UNKNOWN",1,"B","","","TRACE","TERR")
+43 SET RACEUNK=TRACE("DILIST",2,1)_U_TRACE("DILIST",1,1)
End DoDot:1
+44 IF $DATA(PXRRSEX)
SET PATSCR=1
+45 ;
+46 ;PRVSCR is true if we have a provider screen
+47 IF $DATA(PXRRPRSC)
SET PRVSCR=1
+48 IF '$TEST
SET CLASSNAM=0
SET PRVSCR=0
SET PNAME=1
+49 ;
+50 ;If they are asking for all providers then we don't really need to
+51 ; screen.
+52 ;I PRVSCR I $P(PXRRPRSC,U,1)="A" S CLASSNAM=0,PRVSCR=0,PNAME=1
+53 ;See if all providers were requested.
+54 IF PRVSCR
IF $PIECE(PXRRPRSC,U,1)="A"
SET PRVALL=1
+55 IF '$TEST
SET PRVALL=0
+56 ;
+57 ;PPONLY is true if we want primary providers only.
+58 IF PRVSCR
IF $PIECE(PXRRPRSC,U,1)="P"
SET PPONLY=1
+59 IF '$TEST
SET PPONLY=0
+60 ;
+61 ;Allow the task to be cleaned up upon successful completion.
+62 SET ZTREQ="@"
+63 ;
+64 SET BD=PXRRBDT-.0001
+65 SET ED=PXRREDT+.2359
NDATE SET BD=$ORDER(^AUPNVSIT("B",BD))
+1 ;If we have passed the ending date we are done.
+2 IF (BD>ED)!(BD="")
GOTO DONE
+3 ;
+4 ;Check for a user request to stop the task.
+5 IF $$S^%ZTLOAD
SET ZTSTOP=1
DO EXIT^PXRRFDD
+6 ;
+7 ;Get the VISIT IEN
+8 SET VIEN=0
VISIT SET VIEN=$ORDER(^AUPNVSIT("B",BD,VIEN))
+1 IF VIEN=""
GOTO NDATE
+2 SET VISIT=^AUPNVSIT(VIEN,0)
+3 ;
+4 ;If this is an interactive session let the user know that something
+5 ;is happening.
+6 IF '(PXRRQUE!$DATA(IO("S")))
DO SPIN^PXRRBUSY("Sorting encounters",.BUSY)
+7 ;
+8 ;Service category screen.
+9 IF $DATA(PXRRSCAT)
IF PXRRSCAT'[$PIECE(VISIT,U,7)
GOTO VISIT
+10 ;
+11 ;Encounter type screen.
+12 IF $DATA(PXRRETYP)
IF PXRRETYP'[$PIECE(VISIT,U,3)
GOTO VISIT
+13 ;
+14 ;Patient screen. If we have a patient screen then we need to make a
+15 ;VADPT call to get the patient information.
+16 IF PATSCR
Begin DoDot:1
+17 SET DFN=$PIECE(VISIT,U,5)
+18 DO KVAR^VADPT
+19 DO DEM^VADPT
End DoDot:1
+20 ;
+21 SET FOUND=1
+22 ;
+23 ;Patient DOB screen.
+24 IF $DATA(PXRRDOB)
Begin DoDot:1
+25 SET DOB=$PIECE(VADM(3),U,1)
+26 IF (DOB<PXRRDOBS)!(DOB>PXRRDOBE)
SET FOUND=0
End DoDot:1
+27 IF 'FOUND
GOTO VISIT
+28 ;
+29 ;Patient RACE screen.
+30 IF $DATA(PXRRRACE)
Begin DoDot:1
+31 SET FOUND=0
+32 IF VADM(8)=""
SET VADM(8)=RACEUNK
+33 FOR IC=1:1:NRACE
if FOUND
QUIT
Begin DoDot:2
+34 IF PXRRRACE(IC)=VADM(8)
SET FOUND=1
End DoDot:2
End DoDot:1
+35 IF 'FOUND
GOTO VISIT
+36 ;
+37 ;Patient SEX screen.
+38 IF $DATA(PXRRSEX)
Begin DoDot:1
+39 IF PXRRSEX'=VADM(5)
SET FOUND=0
End DoDot:1
+40 IF 'FOUND
GOTO VISIT
+41 ;
+42 ;Make sure that the facility is on the list.
+43 SET FOUND=0
+44 SET FAC=$PIECE(VISIT,U,6)
+45 FOR IC=1:1:NFAC
IF $PIECE(PXRRFAC(IC),U,1)=FAC
Begin DoDot:1
+46 SET FACILITY=FAC
+47 SET FOUND=1
End DoDot:1
QUIT
+48 IF 'FOUND
GOTO VISIT
+49 ;
+50 ;Provider screen.
+51 SET PRVIEN=0
PRV ;To allow for encounters without a provider the check for a null PRVIEN
+1 ;is made after everything else has been done.
+2 IF PRVIEN=""
GOTO VISIT
+3 IF PRVSCR
Begin DoDot:1
+4 SET PRVIEN=$ORDER(^AUPNVPRV("AD",VIEN,PRVIEN))
+5 IF $LENGTH(PRVIEN)>0
SET NEWPIEN=$PIECE(^AUPNVPRV(PRVIEN,0),U,1)
+6 IF '$TEST
SET NEWPIEN=0
+7 SET (CLASSNAM,PNAME)=1
End DoDot:1
+8 SET FOUND=1
+9 ;
+10 ;All providers by name.
+11 IF PRVALL
Begin DoDot:1
+12 SET PNAME=$PIECE($GET(^VA(200,NEWPIEN,0)),U,1)
+13 IF $LENGTH(PNAME)=0
SET PNAME=1
+14 IF '$TEST
SET PNAME=PNAME_U_NEWPIEN
End DoDot:1
+15 ;
+16 ;List of providers.
+17 IF $DATA(PXRRPRPL)
Begin DoDot:1
+18 SET FOUND=0
+19 FOR IC=1:1:NPL
IF $PIECE(PXRRPRPL(IC),U,2)=NEWPIEN
Begin DoDot:2
+20 ;Mark this provider as being found.
+21 SET $PIECE(PXRRPRPL(IC),U,4)="M"
+22 SET PNAME=$PIECE(PXRRPRPL(IC),U,1,2)
+23 SET FOUND=1
End DoDot:2
QUIT
End DoDot:1
+24 ;
+25 ;If we are storing provider names, i.e., PNAME'=1, then store the Person
+26 ;Class alpha abbreviation as the third piece of PNAME.
+27 IF PNAME'=1
Begin DoDot:1
+28 SET PCLASS=$$OCCUP^PXBGPRV(NEWPIEN,BD,"",1)
+29 SET TEMP=$$ALPHA^PXRRPECU(PCLASS)
+30 SET PNAME=PNAME_U_TEMP
End DoDot:1
+31 IF 'FOUND
GOTO PRV
+32 ;
+33 ;Person class screen.
+34 IF $DATA(PXRRPECL)
Begin DoDot:1
+35 SET CLASSNAM=$$OCCUP^PXBGPRV(NEWPIEN,BD,"",1,"")
+36 SET FOUND=$$MATCH^PXRRPECU(CLASSNAM)
+37 IF FOUND
SET CLASSNAM=$PIECE(CLASSNAM,U,7)
End DoDot:1
+38 IF 'FOUND
GOTO PRV
+39 ;
+40 ;Primary Provider only.
+41 IF PPONLY
Begin DoDot:1
+42 SET FOUND=0
+43 IF PRVIEN>0
Begin DoDot:2
+44 IF $PIECE(^AUPNVPRV(PRVIEN,0),U,4)="P"
SET FOUND=1
End DoDot:2
End DoDot:1
+45 IF 'FOUND
GOTO PRV
+46 ;
+47 SET HLOCNAM=1
+48 ;By Clinic
+49 IF CLINIC
Begin DoDot:1
+50 SET CLINIEN=$PIECE(VISIT,U,8)
+51 SET TEMP=$SELECT(+CLINIEN>0:^DIC(40.7,CLINIEN,0),1:"Unknown")
+52 SET HLOCNAM=$PIECE(TEMP,U,1)_U_CLINIEN_U_$PIECE(TEMP,U,2)
End DoDot:1
+53 ;Clinic screen.
+54 IF CSSCR
Begin DoDot:1
+55 SET FOUND=0
+56 FOR IC=1:1:NCS
IF $PIECE(PXRRCS(IC),U,2)=CLINIEN
Begin DoDot:2
+57 ;Mark the clinic as being matched.
+58 SET $PIECE(PXRRCS(IC),U,4)="M"
+59 SET FOUND=1
End DoDot:2
QUIT
End DoDot:1
+60 IF 'FOUND
GOTO VISIT
+61 ;
+62 ;By hospital location.
+63 IF HLOC
Begin DoDot:1
+64 SET HLOCIEN=$PIECE(VISIT,U,22)
+65 IF +HLOCIEN>0
Begin DoDot:2
+66 SET HLOCNAM=$PIECE(^SC(HLOCIEN,0),U,1)_U_HLOCIEN
+67 SET CLINIEN=$PIECE(^SC(HLOCIEN,0),U,7)
+68 SET TEMP=$SELECT(+CLINIEN>0:^DIC(40.7,CLINIEN,0),1:"")
+69 SET HLOCNAM=$PIECE(^SC(HLOCIEN,0),U,1)_U_HLOCIEN_U_$PIECE(TEMP,U,2)
End DoDot:2
+70 IF '$TEST
Begin DoDot:2
+71 ;No hospital location, see if we can at least find the clinic.
+72 SET HLOCNAM="Unknown"
+73 SET CLINIEN=$PIECE(VISIT,U,8)
+74 SET TEMP=$SELECT(+CLINIEN>0:^DIC(40.7,CLINIEN,0),1:"")
+75 SET HLOCNAM="Unknown"_U_U_$PIECE(TEMP,U,2)
End DoDot:2
End DoDot:1
+76 ;Hospital location screen.
+77 IF HSSCR
Begin DoDot:1
+78 SET FOUND=0
+79 FOR IC=1:1:NHL
IF $PIECE(PXRRLCHL(IC),U,2)=HLOCIEN
Begin DoDot:2
+80 ;Mark the hospital location as being matched.
+81 SET $PIECE(PXRRLCHL(IC),U,4)="M"
+82 SET FOUND=1
End DoDot:2
QUIT
End DoDot:1
+83 IF 'FOUND
GOTO VISIT
+84 ;
+85 ;At this point we have an encounter that can be added to the list.
+86 SET ^XTMP(PXRRXTMP,"ENCTR",FACILITY,PNAME,CLASSNAM,HLOCNAM,VIEN)=""
+87 ;
+88 ;Get the next encounter.
+89 GOTO VISIT
+90 ;
DONE ;
+1 DO KVAR^VADPT
+2 IF '(PXRRQUE!$DATA(IO("S")))
DO DONE^PXRRBUSY("done")
+3 ;
+4 ;If there were selected clinic stops build dummy entries for all
+5 ;those without entries.
+6 IF $DATA(PXRRCS)
Begin DoDot:1
+7 FOR FAC=1:1:NFAC
Begin DoDot:2
+8 SET FACILITY=$PIECE(PXRRFAC(FAC),U,1)
+9 FOR IC=1:1:NCS
Begin DoDot:3
+10 IF $PIECE(PXRRCS(IC),U,4)'="M"
Begin DoDot:4
+11 SET PNAME=0
+12 SET CLASSNAM=0
+13 SET HLOCNAM=PXRRCS(IC)
+14 SET ^XTMP(PXRRXTMP,"ENCTR",FACILITY,PNAME,CLASSNAM,HLOCNAM,0)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 ;
+16 ;If there were selected hospital locations build dummy entries for all
+17 ;those without entries.
+18 IF $DATA(PXRRLCHL)
Begin DoDot:1
+19 FOR FAC=1:1:NFAC
Begin DoDot:2
+20 SET FACILITY=$PIECE(PXRRFAC(FAC),U,1)
+21 FOR IC=1:1:NHL
Begin DoDot:3
+22 IF $PIECE(PXRRLCHL(IC),U,4)'="M"
Begin DoDot:4
+23 SET PNAME=0
+24 SET CLASSNAM=0
+25 SET HLOCNAM=PXRRLCHL(IC)
+26 SET ^XTMP(PXRRXTMP,"ENCTR",FACILITY,PNAME,CLASSNAM,HLOCNAM,0)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+27 ;
+28 ;If there were selected providers build dummy entries for all those
+29 ;without encounters.
+30 IF $DATA(PXRRPRPL)
Begin DoDot:1
+31 NEW CLASSLST,JC,NPCLASS
+32 FOR FAC=1:1:NFAC
Begin DoDot:2
+33 SET FACILITY=$PIECE(PXRRFAC(FAC),U,1)
+34 FOR IC=1:1:NPL
Begin DoDot:3
+35 IF $PIECE(PXRRPRPL(IC),U,4)'="M"
Begin DoDot:4
+36 SET PNAME=$PIECE(PXRRPRPL(IC),U,1,2)
+37 SET NEWPIEN=$PIECE(PNAME,U,2)
+38 ;Get the person class list for this provider.
+39 SET NPCLASS=$$PCLLIST^PXRRPECU(NEWPIEN,PXRRBDT,PXRREDT,.CLASSLST)
+40 FOR JC=1:1:NPCLASS
Begin DoDot:5
+41 SET TEMP=PNAME_U_CLASSLST(JC)
+42 SET ^XTMP(PXRRXTMP,"ENCTR",FACILITY,TEMP,0,0)=""
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+43 ;
+44 ;If there were person classes build dummy entries for all those
+45 ;without entries.
+46 IF $DATA(PXRRPECL)
Begin DoDot:1
+47 FOR FAC=1:1:NFAC
Begin DoDot:2
+48 SET FACILITY=$PIECE(PXRRFAC(FAC),U,1)
+49 FOR IC=1:1:NCL
Begin DoDot:3
+50 IF $PIECE(PXRRPECL(IC),U,4)'="M"
Begin DoDot:4
+51 SET PNAME=0
+52 SET CLASSNAM=$PIECE(PXRRPECL(IC),U,1,3)
+53 SET HLOCNAM=0
+54 SET ^XTMP(PXRRXTMP,"ENCTR",FACILITY,PNAME,CLASSNAM,HLOCNAM,0)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+55 ;
EXIT ;
+1 ;Run the next task in the series.
+2 IF PXRRQUE
Begin DoDot:1
+3 NEW DESC,ROUTINE,TASK
+4 SET DESC="Frequency of Diagnosis Report - sort diagnosis data"
+5 SET ROUTINE="SORT^PXRRFDSD"
+6 SET TASK=^XTMP(PXRRXTMP,"SORTDZTSK")
+7 SET ZTDTH=$$NOW^XLFDT
+8 DO REQUE^PXRRQUE(DESC,ROUTINE,TASK)
End DoDot:1
+9 IF '$TEST
DO SORT^PXRRFDSD
+10 ;
+11 QUIT
