PXRMPDR ;SLC/AGP,PKR - Patient List Demographic report main routine ;09/02/2009
;;2.0;CLINICAL REMINDERS;**4,6,12**;Feb 04, 2005;Build 73
;
EN(PLIEN) ; -- main entry point for PXRM PATIENT LIST DEMOGRAPHIC
N ARRAY,DC,DDATA,DELIM,DTOUT,DUOUT
W @IOF
K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J)
S DELIM=0
OPTION ;
W !,"Select the items to include on the report."
ADDSEL D ADDSEL^PXRMPDRS(.DDATA,"ADD")
I $D(DTOUT)!$D(DUOUT) Q
APPSEL D APPSEL^PXRMPDRS(.DDATA,"APP")
I $D(DTOUT)!$D(DUOUT) G ADDSEL
DEMSEL D DEMSEL^PXRMPDRS(.DDATA,"DEM")
I $D(DTOUT)!$D(DUOUT) G APPSEL
PFACSEL S DDATA("PFAC",0)=$$ASKYN^PXRMEUT("N","Include the patient's preferred facility")
I $D(DTOUT)!$D(DUOUT) G DEMSEL
S DDATA("PFAC","LEN")=$S(DDATA("PFAC",0)=1:1,1:0)
ELIGSEL D ELIGSEL^PXRMPDRS(.DDATA,"ELIG")
I $D(DTOUT)!$D(DUOUT) G PFACSEL
DATASEL D DATASEL^PXRMPDRS(PLIEN,.DDATA,"FIND")
I $D(DTOUT)!$D(DUOUT) G ELIGSEL
INPSEL D INPSEL^PXRMPDRS(.DDATA,"INP")
I $D(DTOUT)!$D(DUOUT) G DATASEL
REMDATA D REMSEL^PXRMPDRS(PLIEN,.DDATA,"REM")
I $D(DTOUT)!$D(DUOUT) G INPSEL
S DELIM=$$ASKYN^PXRMEUT("Y","Delimited Report:")
I $D(DTOUT)!$D(DUOUT) G REMDATA
S DC=$S(DELIM:$$DELIMSEL^PXRMXSD,1:U)
I $D(DTOUT)!$D(DUOUT) G OPTION
DEVICE ;
N DESC,DIR,PXRMQUE,RTN,SAVE,%ZIS
S %ZIS="M"
S DESC="Patient List Demographic Report"
S RTN="GETPDATA^PXRMPDR(DELIM,DC,PLIEN,.DDATA)"
S SAVE("DELIM")="",SAVE("DC")="",SAVE("PLIEN")=""
S SAVE("DDATA(")=""
S PXRMQUE=$$DEVICE^PXRMXQUE(RTN,DESC,.SAVE,.%ZIS,1)
I PXRMQUE'="" G EXIT
I $D(DTOUT)!$D(DUOUT) G EXIT
S DIR(0)="E" D ^DIR
EXIT D KVA^VADPT
K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J)
Q
;
GETPDATA(DELIM,DC,PLIEN,DDATA) ;
N DATA,DATE,DCREAT,DFN,DTYPE,ERRMSG
N GETADD,GETAPP,GETDEM,GETELIG,GETFIND,GETINP,GETREM
N IEN,IND,JND,KND,LND
N LISTNAME,PIECE
N PDATA,PNAME,RIEN,TDATA
K ^TMP("PXRMPD",$J)
S LISTNAME=$P(^PXRMXP(810.5,PLIEN,0),U,1)
S DCREAT=$P(^PXRMXP(810.5,PLIEN,0),U,4)
S GETDEM=$S(DDATA("DEM","LEN")>0:1,1:0)
S GETADD=$S(DDATA("ADD","LEN")>0:1,1:0)
S GETINP=$S(DDATA("INP","LEN")>0:1,1:0)
S GETELIG=$S(DDATA("ELIG","LEN")>0:1,1:0)
S GETAPP=$S(DDATA("APP","LEN")>0:1,1:0)
S GETFIND=$S(DDATA("FIND","LEN")>0:1,1:0)
S GETREM=$S(DDATA("REM","LEN")>0:1,1:0)
S IEN=0
F S IEN=+$O(^PXRMXP(810.5,PLIEN,30,IEN)) Q:IEN=0 D
. S DFN=$P(^PXRMXP(810.5,PLIEN,30,IEN,0),U,1) I DFN="" Q
.;#DBIA 10035
. S PNAME=$P($G(^DPT(DFN,0)),U,1)
. I PNAME="" S PNAME="UNDEFINED"_DFN
. S ^TMP("PXRMPLN",$J,PNAME,DFN)=""
. S PDATA=""
. I GETDEM D
.. N VADM
.. D DEM^VADPT
.. F IND=1:1:DDATA("DEM","LEN") D
... S JND=$P(DDATA("DEM"),",",IND)
... S KND=0
... F S KND=$O(DDATA("DEM",JND,KND)) Q:KND="" D
.... S PIECE=$P(DDATA("DEM",JND,KND),U,2)
.... S TDATA=$P(VADM(KND),U,PIECE)
.... S LND=""
.... F S LND=$O(VADM(KND,LND)) Q:LND="" D
..... I TDATA'="" S TDATA=TDATA_"~"
..... S TDATA=TDATA_$P(VADM(KND,LND),U,PIECE)
.... I KND=2,'DDATA("DEM","FULLSSN") S TDATA=$E(TDATA,8,11)
.... S $P(PDATA,U,KND)=TDATA
.. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"DEM")=PDATA,PDATA=""
. I DDATA("PFAC",0)=1 D
..;DBIA #1850
.. S TDATA=$$GET1^DIQ(2,DFN,27.02,"E","","ERRMSG")
.. I TDATA="" S TDATA="NONE"
.. S ^TMP("PXRMPLD",$J,DFN,"PFAC")=TDATA
. I GETADD D
.. N ADDTYPE,LND,MND,OFFSET,VAPA
.. D ADD^VADPT
.. S ADDTYPE=$S(((DT'<VAPA(9))&(DT'>VAPA(10))):"T",1:"R")
..;If the confidential address is active make sure the categories
..;match those that were selected. VHA Directive 2003-025 states
..;the confidential address must be used if it is active.
.. I VAPA(12),DDATA("ADD")["1," D
... F LND=1:1:DDATA("ADD",22,"LEN") D
.... S MND=$P(DDATA("ADD",22,"LIST"),",",LND)
....;If this category = VAPA(22,MND), was selected use it.
.... I $D(VAPA(22,MND)) S ADDTYPE="C"
.. S OFFSET=$S(ADDTYPE="C":12,1:0)
.. S (VAPA(23),VAPA(23+OFFSET))=ADDTYPE
.. F IND=1:1:DDATA("ADD","LEN") D
... S JND=$P(DDATA("ADD"),",",IND)
...;The offset is only used for addresses.
... I JND=2 S OFFSET=0
... S KND=0
... F S KND=+$O(DDATA("ADD",JND,KND)) Q:KND=0 D
.... S PIECE=$P(DDATA("ADD",JND,KND),U,2)
.... S TDATA=$P(VAPA(KND+OFFSET),U,PIECE)
.... S $P(PDATA,U,KND)=TDATA
.. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ADD")=PDATA,PDATA=""
. I GETINP D
.. N VAIP
.. D INP^VADPT
.. F IND=1:1:DDATA("INP","LEN") D
... S JND=$P(DDATA("INP"),",",IND)
... S KND=0
... F S KND=$O(DDATA("INP",JND,KND)) Q:KND="" D
.... S PIECE=$P(DDATA("INP",JND,KND),U,2)
.... S TDATA=$P(VAIN(KND),U,PIECE)
.... S $P(PDATA,U,KND)=TDATA
.. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"INP")=PDATA,PDATA=""
. I GETELIG D
.. N VAEL
.. D ELIG^VADPT
.. F IND=1:1:DDATA("ELIG","LEN") D
... S JND=$P(DDATA("ELIG"),",",IND)
... S KND=0
... F S KND=$O(DDATA("ELIG",JND,KND)) Q:KND="" D
.... S PIECE=$P(DDATA("ELIG",JND,KND),U,2)
.... S TDATA=$P(VAEL(KND),U,PIECE)
.... I KND=4 S TDATA=$S(TDATA=1:"YES",1:"NO")
.... S $P(PDATA,U,KND)=TDATA
.. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ELIG")=PDATA,PDATA=""
. D KVA^VADPT
. I GETREM D
.. S IND=0
.. F S IND=$O(DDATA("REM","IEN",IND)) Q:IND="" D
... S PDATA=$G(^PXRMXP(810.5,PLIEN,30,IEN,"REM",IND,0))
... I PDATA="" Q
... S RIEN=$P(PDATA,U,1)
... S ^TMP("PXRMPLD",$J,DFN,"REM",RIEN)=PDATA,PDATA=""
. I GETFIND D
.. N DL
.. F IND=1:1:DDATA("FIND","LEN") D
... S JND=$P(DDATA("FIND"),",",IND)
... S DTYPE=DDATA("FIND",JND,JND)
... S KND=$O(^PXRMXP(810.5,PLIEN,30,IEN,"DATA","B",DTYPE,""))
... S DL=$S(KND="":0,1:$L(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U))
... S DATA=$S(KND="":"",1:$P(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U,2,DL))
... S ^TMP("PXRMPLD",$J,DFN,"FIND",JND)=DATA
;Get appointment data for all patients on the list.
I GETAPP D
. N APPLIST,ARRAY,COUNT,DONE
. S ARRAY(1)=DT,ARRAY(3)="I;R",ARRAY(4)="^TMP($J,""PXRMPL"""
. S ARRAY("FLDS")=""
. F IND=1:1:DDATA("APP","LEN") D
.. S JND=$P(DDATA("APP"),",",IND)
.. S KND=0
.. F S KND=$O(DDATA("APP",JND,KND)) Q:KND="" S ARRAY("FLDS")=ARRAY("FLDS")_KND_";"
. K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
. S IND=0
. F S IND=+$O(^PXRMXP(810.5,PLIEN,30,IND)) Q:IND=0 D
.. S DFN=$P(^PXRMXP(810.5,PLIEN,30,IND,0),U,1)
.. I DFN'="" S ^TMP($J,"PXRMPL",DFN)=""
. S COUNT=$$SDAPI^SDAMA301(.ARRAY)
. I COUNT=-1 D Q
.. D APPERR^PXRMPDRS
.. S DDATA("APP","ERROR")=""
.. K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
.;Data is ^TMP($J,"SDAMA301",DFN,CLINIC,DATE)=DATE^CLINIC
.;Resort by DATE then CLINIC.
. S DFN=""
. F S DFN=$O(^TMP($J,"SDAMA301",DFN)) Q:DFN="" D
.. K APPLIST
.. S JND=0
.. F S JND=$O(^TMP($J,"SDAMA301",DFN,JND)) Q:JND="" D
... S DATE=0
... F S DATE=$O(^TMP($J,"SDAMA301",DFN,JND,DATE)) Q:DATE="" S APPLIST(DATE,JND)=""
.. S (DATE,DONE,KND)=0
.. F S DATE=$O(APPLIST(DATE)) Q:(DONE)!(DATE="") D
... S JND=0
... F S JND=$O(APPLIST(DATE,JND)) Q:(DONE)!(JND="") D
.... S KND=KND+1
.... I KND=DDATA("APP","MAX") S DONE=1
.... S TDATA=^TMP($J,"SDAMA301",DFN,JND,DATE)
.... S PDATA=$$FMTE^XLFDT($P(TDATA,U,1))
.... S TDATA=$P(TDATA,U,2),TDATA=$P(TDATA,";",2)
.... S PDATA=PDATA_U_TDATA
.... S ^TMP("PXRMPLD",$J,DFN,"APP",KND)=PDATA
. K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
I DELIM=1 D DELIMPR^PXRMPDRP(DC,PLIEN,.DDATA)
I DELIM=0 D REGPR^PXRMPDRP(PLIEN,.DDATA)
Q
;
LENGTH(STR,STR1) ;
I ($L(STR)+$L(STR1))>245 W !,STR S STR=STR1
E S STR=STR_U_STR1,STR1=""
Q
;
PXRMPDR ;SLC/AGP,PKR - Patient List Demographic report main routine ;09/02/2009
+1 ;;2.0;CLINICAL REMINDERS;**4,6,12**;Feb 04, 2005;Build 73
+2 ;
EN(PLIEN) ; -- main entry point for PXRM PATIENT LIST DEMOGRAPHIC
+1 NEW ARRAY,DC,DDATA,DELIM,DTOUT,DUOUT
+2 WRITE @IOF
+3 KILL ^TMP("PXRMPLD",$JOB),^TMP("PXRMPLN",$JOB)
+4 SET DELIM=0
OPTION ;
+1 WRITE !,"Select the items to include on the report."
ADDSEL DO ADDSEL^PXRMPDRS(.DDATA,"ADD")
+1 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
APPSEL DO APPSEL^PXRMPDRS(.DDATA,"APP")
+1 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO ADDSEL
DEMSEL DO DEMSEL^PXRMPDRS(.DDATA,"DEM")
+1 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO APPSEL
PFACSEL SET DDATA("PFAC",0)=$$ASKYN^PXRMEUT("N","Include the patient's preferred facility")
+1 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO DEMSEL
+2 SET DDATA("PFAC","LEN")=$SELECT(DDATA("PFAC",0)=1:1,1:0)
ELIGSEL DO ELIGSEL^PXRMPDRS(.DDATA,"ELIG")
+1 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO PFACSEL
DATASEL DO DATASEL^PXRMPDRS(PLIEN,.DDATA,"FIND")
+1 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO ELIGSEL
INPSEL DO INPSEL^PXRMPDRS(.DDATA,"INP")
+1 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO DATASEL
REMDATA DO REMSEL^PXRMPDRS(PLIEN,.DDATA,"REM")
+1 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO INPSEL
+2 SET DELIM=$$ASKYN^PXRMEUT("Y","Delimited Report:")
+3 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO REMDATA
+4 SET DC=$SELECT(DELIM:$$DELIMSEL^PXRMXSD,1:U)
+5 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO OPTION
DEVICE ;
+1 NEW DESC,DIR,PXRMQUE,RTN,SAVE,%ZIS
+2 SET %ZIS="M"
+3 SET DESC="Patient List Demographic Report"
+4 SET RTN="GETPDATA^PXRMPDR(DELIM,DC,PLIEN,.DDATA)"
+5 SET SAVE("DELIM")=""
SET SAVE("DC")=""
SET SAVE("PLIEN")=""
+6 SET SAVE("DDATA(")=""
+7 SET PXRMQUE=$$DEVICE^PXRMXQUE(RTN,DESC,.SAVE,.%ZIS,1)
+8 IF PXRMQUE'=""
GOTO EXIT
+9 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
+10 SET DIR(0)="E"
DO ^DIR
EXIT DO KVA^VADPT
+1 KILL ^TMP("PXRMPLD",$JOB),^TMP("PXRMPLN",$JOB)
+2 QUIT
+3 ;
GETPDATA(DELIM,DC,PLIEN,DDATA) ;
+1 NEW DATA,DATE,DCREAT,DFN,DTYPE,ERRMSG
+2 NEW GETADD,GETAPP,GETDEM,GETELIG,GETFIND,GETINP,GETREM
+3 NEW IEN,IND,JND,KND,LND
+4 NEW LISTNAME,PIECE
+5 NEW PDATA,PNAME,RIEN,TDATA
+6 KILL ^TMP("PXRMPD",$JOB)
+7 SET LISTNAME=$PIECE(^PXRMXP(810.5,PLIEN,0),U,1)
+8 SET DCREAT=$PIECE(^PXRMXP(810.5,PLIEN,0),U,4)
+9 SET GETDEM=$SELECT(DDATA("DEM","LEN")>0:1,1:0)
+10 SET GETADD=$SELECT(DDATA("ADD","LEN")>0:1,1:0)
+11 SET GETINP=$SELECT(DDATA("INP","LEN")>0:1,1:0)
+12 SET GETELIG=$SELECT(DDATA("ELIG","LEN")>0:1,1:0)
+13 SET GETAPP=$SELECT(DDATA("APP","LEN")>0:1,1:0)
+14 SET GETFIND=$SELECT(DDATA("FIND","LEN")>0:1,1:0)
+15 SET GETREM=$SELECT(DDATA("REM","LEN")>0:1,1:0)
+16 SET IEN=0
+17 FOR
SET IEN=+$ORDER(^PXRMXP(810.5,PLIEN,30,IEN))
IF IEN=0
QUIT
Begin DoDot:1
+18 SET DFN=$PIECE(^PXRMXP(810.5,PLIEN,30,IEN,0),U,1)
IF DFN=""
QUIT
+19 ;#DBIA 10035
+20 SET PNAME=$PIECE($GET(^DPT(DFN,0)),U,1)
+21 IF PNAME=""
SET PNAME="UNDEFINED"_DFN
+22 SET ^TMP("PXRMPLN",$JOB,PNAME,DFN)=""
+23 SET PDATA=""
+24 IF GETDEM
Begin DoDot:2
+25 NEW VADM
+26 DO DEM^VADPT
+27 FOR IND=1:1:DDATA("DEM","LEN")
Begin DoDot:3
+28 SET JND=$PIECE(DDATA("DEM"),",",IND)
+29 SET KND=0
+30 FOR
SET KND=$ORDER(DDATA("DEM",JND,KND))
IF KND=""
QUIT
Begin DoDot:4
+31 SET PIECE=$PIECE(DDATA("DEM",JND,KND),U,2)
+32 SET TDATA=$PIECE(VADM(KND),U,PIECE)
+33 SET LND=""
+34 FOR
SET LND=$ORDER(VADM(KND,LND))
IF LND=""
QUIT
Begin DoDot:5
+35 IF TDATA'=""
SET TDATA=TDATA_"~"
+36 SET TDATA=TDATA_$PIECE(VADM(KND,LND),U,PIECE)
End DoDot:5
+37 IF KND=2
IF 'DDATA("DEM","FULLSSN")
SET TDATA=$EXTRACT(TDATA,8,11)
+38 SET $PIECE(PDATA,U,KND)=TDATA
End DoDot:4
End DoDot:3
+39 IF PDATA'=""
SET ^TMP("PXRMPLD",$JOB,DFN,"DEM")=PDATA
SET PDATA=""
End DoDot:2
+40 IF DDATA("PFAC",0)=1
Begin DoDot:2
+41 ;DBIA #1850
+42 SET TDATA=$$GET1^DIQ(2,DFN,27.02,"E","","ERRMSG")
+43 IF TDATA=""
SET TDATA="NONE"
+44 SET ^TMP("PXRMPLD",$JOB,DFN,"PFAC")=TDATA
End DoDot:2
+45 IF GETADD
Begin DoDot:2
+46 NEW ADDTYPE,LND,MND,OFFSET,VAPA
+47 DO ADD^VADPT
+48 SET ADDTYPE=$SELECT(((DT'<VAPA(9))&(DT'>VAPA(10))):"T",1:"R")
+49 ;If the confidential address is active make sure the categories
+50 ;match those that were selected. VHA Directive 2003-025 states
+51 ;the confidential address must be used if it is active.
+52 IF VAPA(12)
IF DDATA("ADD")["1,"
Begin DoDot:3
+53 FOR LND=1:1:DDATA("ADD",22,"LEN")
Begin DoDot:4
+54 SET MND=$PIECE(DDATA("ADD",22,"LIST"),",",LND)
+55 ;If this category = VAPA(22,MND), was selected use it.
+56 IF $DATA(VAPA(22,MND))
SET ADDTYPE="C"
End DoDot:4
End DoDot:3
+57 SET OFFSET=$SELECT(ADDTYPE="C":12,1:0)
+58 SET (VAPA(23),VAPA(23+OFFSET))=ADDTYPE
+59 FOR IND=1:1:DDATA("ADD","LEN")
Begin DoDot:3
+60 SET JND=$PIECE(DDATA("ADD"),",",IND)
+61 ;The offset is only used for addresses.
+62 IF JND=2
SET OFFSET=0
+63 SET KND=0
+64 FOR
SET KND=+$ORDER(DDATA("ADD",JND,KND))
IF KND=0
QUIT
Begin DoDot:4
+65 SET PIECE=$PIECE(DDATA("ADD",JND,KND),U,2)
+66 SET TDATA=$PIECE(VAPA(KND+OFFSET),U,PIECE)
+67 SET $PIECE(PDATA,U,KND)=TDATA
End DoDot:4
End DoDot:3
+68 IF PDATA'=""
SET ^TMP("PXRMPLD",$JOB,DFN,"ADD")=PDATA
SET PDATA=""
End DoDot:2
+69 IF GETINP
Begin DoDot:2
+70 NEW VAIP
+71 DO INP^VADPT
+72 FOR IND=1:1:DDATA("INP","LEN")
Begin DoDot:3
+73 SET JND=$PIECE(DDATA("INP"),",",IND)
+74 SET KND=0
+75 FOR
SET KND=$ORDER(DDATA("INP",JND,KND))
IF KND=""
QUIT
Begin DoDot:4
+76 SET PIECE=$PIECE(DDATA("INP",JND,KND),U,2)
+77 SET TDATA=$PIECE(VAIN(KND),U,PIECE)
+78 SET $PIECE(PDATA,U,KND)=TDATA
End DoDot:4
End DoDot:3
+79 IF PDATA'=""
SET ^TMP("PXRMPLD",$JOB,DFN,"INP")=PDATA
SET PDATA=""
End DoDot:2
+80 IF GETELIG
Begin DoDot:2
+81 NEW VAEL
+82 DO ELIG^VADPT
+83 FOR IND=1:1:DDATA("ELIG","LEN")
Begin DoDot:3
+84 SET JND=$PIECE(DDATA("ELIG"),",",IND)
+85 SET KND=0
+86 FOR
SET KND=$ORDER(DDATA("ELIG",JND,KND))
IF KND=""
QUIT
Begin DoDot:4
+87 SET PIECE=$PIECE(DDATA("ELIG",JND,KND),U,2)
+88 SET TDATA=$PIECE(VAEL(KND),U,PIECE)
+89 IF KND=4
SET TDATA=$SELECT(TDATA=1:"YES",1:"NO")
+90 SET $PIECE(PDATA,U,KND)=TDATA
End DoDot:4
End DoDot:3
+91 IF PDATA'=""
SET ^TMP("PXRMPLD",$JOB,DFN,"ELIG")=PDATA
SET PDATA=""
End DoDot:2
+92 DO KVA^VADPT
+93 IF GETREM
Begin DoDot:2
+94 SET IND=0
+95 FOR
SET IND=$ORDER(DDATA("REM","IEN",IND))
IF IND=""
QUIT
Begin DoDot:3
+96 SET PDATA=$GET(^PXRMXP(810.5,PLIEN,30,IEN,"REM",IND,0))
+97 IF PDATA=""
QUIT
+98 SET RIEN=$PIECE(PDATA,U,1)
+99 SET ^TMP("PXRMPLD",$JOB,DFN,"REM",RIEN)=PDATA
SET PDATA=""
End DoDot:3
End DoDot:2
+100 IF GETFIND
Begin DoDot:2
+101 NEW DL
+102 FOR IND=1:1:DDATA("FIND","LEN")
Begin DoDot:3
+103 SET JND=$PIECE(DDATA("FIND"),",",IND)
+104 SET DTYPE=DDATA("FIND",JND,JND)
+105 SET KND=$ORDER(^PXRMXP(810.5,PLIEN,30,IEN,"DATA","B",DTYPE,""))
+106 SET DL=$SELECT(KND="":0,1:$LENGTH(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U))
+107 SET DATA=$SELECT(KND="":"",1:$PIECE(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U,2,DL))
+108 SET ^TMP("PXRMPLD",$JOB,DFN,"FIND",JND)=DATA
End DoDot:3
End DoDot:2
End DoDot:1
+109 ;Get appointment data for all patients on the list.
+110 IF GETAPP
Begin DoDot:1
+111 NEW APPLIST,ARRAY,COUNT,DONE
+112 SET ARRAY(1)=DT
SET ARRAY(3)="I;R"
SET ARRAY(4)="^TMP($J,""PXRMPL"""
+113 SET ARRAY("FLDS")=""
+114 FOR IND=1:1:DDATA("APP","LEN")
Begin DoDot:2
+115 SET JND=$PIECE(DDATA("APP"),",",IND)
+116 SET KND=0
+117 FOR
SET KND=$ORDER(DDATA("APP",JND,KND))
IF KND=""
QUIT
SET ARRAY("FLDS")=ARRAY("FLDS")_KND_";"
End DoDot:2
+118 KILL ^TMP($JOB,"PXRMPL"),^TMP($JOB,"SDAMA301")
+119 SET IND=0
+120 FOR
SET IND=+$ORDER(^PXRMXP(810.5,PLIEN,30,IND))
IF IND=0
QUIT
Begin DoDot:2
+121 SET DFN=$PIECE(^PXRMXP(810.5,PLIEN,30,IND,0),U,1)
+122 IF DFN'=""
SET ^TMP($JOB,"PXRMPL",DFN)=""
End DoDot:2
+123 SET COUNT=$$SDAPI^SDAMA301(.ARRAY)
+124 IF COUNT=-1
Begin DoDot:2
+125 DO APPERR^PXRMPDRS
+126 SET DDATA("APP","ERROR")=""
+127 KILL ^TMP($JOB,"PXRMPL"),^TMP($JOB,"SDAMA301")
End DoDot:2
QUIT
+128 ;Data is ^TMP($J,"SDAMA301",DFN,CLINIC,DATE)=DATE^CLINIC
+129 ;Resort by DATE then CLINIC.
+130 SET DFN=""
+131 FOR
SET DFN=$ORDER(^TMP($JOB,"SDAMA301",DFN))
IF DFN=""
QUIT
Begin DoDot:2
+132 KILL APPLIST
+133 SET JND=0
+134 FOR
SET JND=$ORDER(^TMP($JOB,"SDAMA301",DFN,JND))
IF JND=""
QUIT
Begin DoDot:3
+135 SET DATE=0
+136 FOR
SET DATE=$ORDER(^TMP($JOB,"SDAMA301",DFN,JND,DATE))
IF DATE=""
QUIT
SET APPLIST(DATE,JND)=""
End DoDot:3
+137 SET (DATE,DONE,KND)=0
+138 FOR
SET DATE=$ORDER(APPLIST(DATE))
IF (DONE)!(DATE="")
QUIT
Begin DoDot:3
+139 SET JND=0
+140 FOR
SET JND=$ORDER(APPLIST(DATE,JND))
IF (DONE)!(JND="")
QUIT
Begin DoDot:4
+141 SET KND=KND+1
+142 IF KND=DDATA("APP","MAX")
SET DONE=1
+143 SET TDATA=^TMP($JOB,"SDAMA301",DFN,JND,DATE)
+144 SET PDATA=$$FMTE^XLFDT($PIECE(TDATA,U,1))
+145 SET TDATA=$PIECE(TDATA,U,2)
SET TDATA=$PIECE(TDATA,";",2)
+146 SET PDATA=PDATA_U_TDATA
+147 SET ^TMP("PXRMPLD",$JOB,DFN,"APP",KND)=PDATA
End DoDot:4
End DoDot:3
End DoDot:2
+148 KILL ^TMP($JOB,"PXRMPL"),^TMP($JOB,"SDAMA301")
End DoDot:1
+149 IF DELIM=1
DO DELIMPR^PXRMPDRP(DC,PLIEN,.DDATA)
+150 IF DELIM=0
DO REGPR^PXRMPDRP(PLIEN,.DDATA)
+151 QUIT
+152 ;
LENGTH(STR,STR1) ;
+1 IF ($LENGTH(STR)+$LENGTH(STR1))>245
WRITE !,STR
SET STR=STR1
+2 IF '$TEST
SET STR=STR_U_STR1
SET STR1=""
+3 QUIT
+4 ;
