PXRMPDR ;SLC/AGP,PKR - Patient List Demographic report main routine ;03/06/2015
;;2.0;CLINICAL REMINDERS;**4,6,12,47**;Feb 04, 2005;Build 291
;
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,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 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 VAIN
.. 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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMPDR 7406 printed Dec 13, 2024@01:48:27 Page 2
PXRMPDR ;SLC/AGP,PKR - Patient List Demographic report main routine ;03/06/2015
+1 ;;2.0;CLINICAL REMINDERS;**4,6,12,47**;Feb 04, 2005;Build 291
+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,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 GETDEM=$SELECT(DDATA("DEM","LEN")>0:1,1:0)
+9 SET GETADD=$SELECT(DDATA("ADD","LEN")>0:1,1:0)
+10 SET GETINP=$SELECT(DDATA("INP","LEN")>0:1,1:0)
+11 SET GETELIG=$SELECT(DDATA("ELIG","LEN")>0:1,1:0)
+12 SET GETAPP=$SELECT(DDATA("APP","LEN")>0:1,1:0)
+13 SET GETFIND=$SELECT(DDATA("FIND","LEN")>0:1,1:0)
+14 SET GETREM=$SELECT(DDATA("REM","LEN")>0:1,1:0)
+15 SET IEN=0
+16 FOR
SET IEN=+$ORDER(^PXRMXP(810.5,PLIEN,30,IEN))
if IEN=0
QUIT
Begin DoDot:1
+17 SET DFN=$PIECE(^PXRMXP(810.5,PLIEN,30,IEN,0),U,1)
IF DFN=""
QUIT
+18 ;#DBIA 10035
+19 SET PNAME=$PIECE($GET(^DPT(DFN,0)),U,1)
+20 IF PNAME=""
SET PNAME="UNDEFINED"_DFN
+21 SET ^TMP("PXRMPLN",$JOB,PNAME,DFN)=""
+22 SET PDATA=""
+23 IF GETDEM
Begin DoDot:2
+24 NEW VADM
+25 DO DEM^VADPT
+26 FOR IND=1:1:DDATA("DEM","LEN")
Begin DoDot:3
+27 SET JND=$PIECE(DDATA("DEM"),",",IND)
+28 SET KND=0
+29 FOR
SET KND=$ORDER(DDATA("DEM",JND,KND))
if KND=""
QUIT
Begin DoDot:4
+30 SET PIECE=$PIECE(DDATA("DEM",JND,KND),U,2)
+31 SET TDATA=$PIECE(VADM(KND),U,PIECE)
+32 SET LND=""
+33 FOR
SET LND=$ORDER(VADM(KND,LND))
if LND=""
QUIT
Begin DoDot:5
+34 IF TDATA'=""
SET TDATA=TDATA_"~"
+35 SET TDATA=TDATA_$PIECE(VADM(KND,LND),U,PIECE)
End DoDot:5
+36 IF KND=2
IF 'DDATA("DEM","FULLSSN")
SET TDATA=$EXTRACT(TDATA,8,11)
+37 SET $PIECE(PDATA,U,KND)=TDATA
End DoDot:4
End DoDot:3
+38 IF PDATA'=""
SET ^TMP("PXRMPLD",$JOB,DFN,"DEM")=PDATA
SET PDATA=""
End DoDot:2
+39 IF DDATA("PFAC",0)=1
Begin DoDot:2
+40 ;DBIA #1850
+41 SET TDATA=$$GET1^DIQ(2,DFN,27.02,"E","","ERRMSG")
+42 IF TDATA=""
SET TDATA="NONE"
+43 SET ^TMP("PXRMPLD",$JOB,DFN,"PFAC")=TDATA
End DoDot:2
+44 IF GETADD
Begin DoDot:2
+45 NEW ADDTYPE,LND,MND,OFFSET,VAPA
+46 DO ADD^VADPT
+47 SET ADDTYPE=$SELECT(((DT'<VAPA(9))&(DT'>VAPA(10))):"T",1:"R")
+48 ;If the confidential address is active make sure the categories
+49 ;match those that were selected. VHA Directive 2003-025 states
+50 ;the confidential address must be used if it is active.
+51 IF VAPA(12)
IF DDATA("ADD")["1,"
Begin DoDot:3
+52 FOR LND=1:1:DDATA("ADD",22,"LEN")
Begin DoDot:4
+53 SET MND=$PIECE(DDATA("ADD",22,"LIST"),",",LND)
+54 ;If this category = VAPA(22,MND), was selected use it.
+55 IF $DATA(VAPA(22,MND))
SET ADDTYPE="C"
End DoDot:4
End DoDot:3
+56 SET OFFSET=$SELECT(ADDTYPE="C":12,1:0)
+57 SET (VAPA(23),VAPA(23+OFFSET))=ADDTYPE
+58 FOR IND=1:1:DDATA("ADD","LEN")
Begin DoDot:3
+59 SET JND=$PIECE(DDATA("ADD"),",",IND)
+60 ;The offset is only used for addresses.
+61 IF JND=2
SET OFFSET=0
+62 SET KND=0
+63 FOR
SET KND=+$ORDER(DDATA("ADD",JND,KND))
if KND=0
QUIT
Begin DoDot:4
+64 SET PIECE=$PIECE(DDATA("ADD",JND,KND),U,2)
+65 SET TDATA=$PIECE(VAPA(KND+OFFSET),U,PIECE)
+66 SET $PIECE(PDATA,U,KND)=TDATA
End DoDot:4
End DoDot:3
+67 IF PDATA'=""
SET ^TMP("PXRMPLD",$JOB,DFN,"ADD")=PDATA
SET PDATA=""
End DoDot:2
+68 IF GETINP
Begin DoDot:2
+69 NEW VAIN
+70 DO INP^VADPT
+71 FOR IND=1:1:DDATA("INP","LEN")
Begin DoDot:3
+72 SET JND=$PIECE(DDATA("INP"),",",IND)
+73 SET KND=0
+74 FOR
SET KND=$ORDER(DDATA("INP",JND,KND))
if KND=""
QUIT
Begin DoDot:4
+75 SET PIECE=$PIECE(DDATA("INP",JND,KND),U,2)
+76 SET TDATA=$PIECE(VAIN(KND),U,PIECE)
+77 SET $PIECE(PDATA,U,KND)=TDATA
End DoDot:4
End DoDot:3
+78 IF PDATA'=""
SET ^TMP("PXRMPLD",$JOB,DFN,"INP")=PDATA
SET PDATA=""
End DoDot:2
+79 IF GETELIG
Begin DoDot:2
+80 NEW VAEL
+81 DO ELIG^VADPT
+82 FOR IND=1:1:DDATA("ELIG","LEN")
Begin DoDot:3
+83 SET JND=$PIECE(DDATA("ELIG"),",",IND)
+84 SET KND=0
+85 FOR
SET KND=$ORDER(DDATA("ELIG",JND,KND))
if KND=""
QUIT
Begin DoDot:4
+86 SET PIECE=$PIECE(DDATA("ELIG",JND,KND),U,2)
+87 SET TDATA=$PIECE(VAEL(KND),U,PIECE)
+88 IF KND=4
SET TDATA=$SELECT(TDATA=1:"YES",1:"NO")
+89 SET $PIECE(PDATA,U,KND)=TDATA
End DoDot:4
End DoDot:3
+90 IF PDATA'=""
SET ^TMP("PXRMPLD",$JOB,DFN,"ELIG")=PDATA
SET PDATA=""
End DoDot:2
+91 DO KVA^VADPT
+92 IF GETREM
Begin DoDot:2
+93 SET IND=0
+94 FOR
SET IND=$ORDER(DDATA("REM","IEN",IND))
if IND=""
QUIT
Begin DoDot:3
+95 SET PDATA=$GET(^PXRMXP(810.5,PLIEN,30,IEN,"REM",IND,0))
+96 IF PDATA=""
QUIT
+97 SET RIEN=$PIECE(PDATA,U,1)
+98 SET ^TMP("PXRMPLD",$JOB,DFN,"REM",RIEN)=PDATA
SET PDATA=""
End DoDot:3
End DoDot:2
+99 IF GETFIND
Begin DoDot:2
+100 NEW DL
+101 FOR IND=1:1:DDATA("FIND","LEN")
Begin DoDot:3
+102 SET JND=$PIECE(DDATA("FIND"),",",IND)
+103 SET DTYPE=DDATA("FIND",JND,JND)
+104 SET KND=$ORDER(^PXRMXP(810.5,PLIEN,30,IEN,"DATA","B",DTYPE,""))
+105 SET DL=$SELECT(KND="":0,1:$LENGTH(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U))
+106 SET DATA=$SELECT(KND="":"",1:$PIECE(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U,2,DL))
+107 SET ^TMP("PXRMPLD",$JOB,DFN,"FIND",JND)=DATA
End DoDot:3
End DoDot:2
End DoDot:1
+108 ;Get appointment data for all patients on the list.
+109 IF GETAPP
Begin DoDot:1
+110 NEW APPLIST,ARRAY,COUNT,DONE
+111 SET ARRAY(1)=DT
SET ARRAY(3)="I;R"
SET ARRAY(4)="^TMP($J,""PXRMPL"""
+112 SET ARRAY("FLDS")=""
+113 FOR IND=1:1:DDATA("APP","LEN")
Begin DoDot:2
+114 SET JND=$PIECE(DDATA("APP"),",",IND)
+115 SET KND=0
+116 FOR
SET KND=$ORDER(DDATA("APP",JND,KND))
if KND=""
QUIT
SET ARRAY("FLDS")=ARRAY("FLDS")_KND_";"
End DoDot:2
+117 KILL ^TMP($JOB,"PXRMPL"),^TMP($JOB,"SDAMA301")
+118 SET IND=0
+119 FOR
SET IND=+$ORDER(^PXRMXP(810.5,PLIEN,30,IND))
if IND=0
QUIT
Begin DoDot:2
+120 SET DFN=$PIECE(^PXRMXP(810.5,PLIEN,30,IND,0),U,1)
+121 IF DFN'=""
SET ^TMP($JOB,"PXRMPL",DFN)=""
End DoDot:2
+122 SET COUNT=$$SDAPI^SDAMA301(.ARRAY)
+123 IF COUNT=-1
Begin DoDot:2
+124 DO APPERR^PXRMPDRS
+125 SET DDATA("APP","ERROR")=""
+126 KILL ^TMP($JOB,"PXRMPL"),^TMP($JOB,"SDAMA301")
End DoDot:2
QUIT
+127 ;Data is ^TMP($J,"SDAMA301",DFN,CLINIC,DATE)=DATE^CLINIC
+128 ;Resort by DATE then CLINIC.
+129 SET DFN=""
+130 FOR
SET DFN=$ORDER(^TMP($JOB,"SDAMA301",DFN))
if DFN=""
QUIT
Begin DoDot:2
+131 KILL APPLIST
+132 SET JND=0
+133 FOR
SET JND=$ORDER(^TMP($JOB,"SDAMA301",DFN,JND))
if JND=""
QUIT
Begin DoDot:3
+134 SET DATE=0
+135 FOR
SET DATE=$ORDER(^TMP($JOB,"SDAMA301",DFN,JND,DATE))
if DATE=""
QUIT
SET APPLIST(DATE,JND)=""
End DoDot:3
+136 SET (DATE,DONE,KND)=0
+137 FOR
SET DATE=$ORDER(APPLIST(DATE))
if (DONE)!(DATE="")
QUIT
Begin DoDot:3
+138 SET JND=0
+139 FOR
SET JND=$ORDER(APPLIST(DATE,JND))
if (DONE)!(JND="")
QUIT
Begin DoDot:4
+140 SET KND=KND+1
+141 IF KND=DDATA("APP","MAX")
SET DONE=1
+142 SET TDATA=^TMP($JOB,"SDAMA301",DFN,JND,DATE)
+143 SET PDATA=$$FMTE^XLFDT($PIECE(TDATA,U,1))
+144 SET TDATA=$PIECE(TDATA,U,2)
SET TDATA=$PIECE(TDATA,";",2)
+145 SET PDATA=PDATA_U_TDATA
+146 SET ^TMP("PXRMPLD",$JOB,DFN,"APP",KND)=PDATA
End DoDot:4
End DoDot:3
End DoDot:2
+147 KILL ^TMP($JOB,"PXRMPL"),^TMP($JOB,"SDAMA301")
End DoDot:1
+148 IF DELIM=1
DO DELIMPR^PXRMPDRP(DC,PLIEN,.DDATA)
+149 IF DELIM=0
DO REGPR^PXRMPDRP(PLIEN,.DDATA)
+150 QUIT
+151 ;
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 ;
