- ECNTPCE ;ALB/JAM-Event Capture Records failing transmission to PCE;Sep 24, 2020@14:55:55
- ;;2.0;EVENT CAPTURE;**61,72,119,152**;8 May 96;Build 19
- EN ; entry point
- K %DT S %DT="AEX",%DT("A")="Start with Date: " D ^%DT I Y<0 G END
- S ECSD=Y,%DT("A")="End with Date: " D ^%DT G:Y<0 END S ECED=Y
- I ECED<ECSD W !,"End date must be after start date",! G EN
- S ECDATE=$$FMTE^XLFDT(ECSD)_U_$$FMTE^XLFDT(ECED)
- S ECSD=ECSD-.0001,ECED=ECED+.9999
- K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Select Device: ",%ZIS="QM"
- D ^%ZIS G:POP END
- I $D(IO("Q")) K IO("Q") D G END
- .S (ZTSAVE("ECDFN"),ZTSAVE("ECDATE"),ZTSAVE("ECED"),ZTSAVE("ECSD"))=""
- .S ZTDESC="ECS RECORDS FAILING TRANSMISSION TO PCE REPORT",ZTRTN="START^ECNTPCE"
- .S ZTIO=ION D ^%ZTLOAD,HOME^%ZIS
- W !,?5,"Please be patient, this may take a few moments..."
- ;
- START ; entry when queued
- N ECOUT,X,Y,DIR,LINE,ECPG,ECRDT,%H,CNT ;119
- S ECOUT=0,ECPG=1
- S %H=$H D YX^%DTC S ECRDT=Y
- U IO
- I $G(ECPTYP)="E" S CNT=1,^TMP($J,"ECRPT",CNT)="DATE/TIME^LOCATION^DSS UNIT^CATEGORY^PATIENT^SSN^PROCEDURE CODE^PROCEDURE NAME^PROV 1^PROV 2^PROV 3^PROV 4^PROV 5^PROV 6^PROV 7^REASON 1^REASON 2^REASON 3" ;119
- I $G(ECPTYP)="E" D GET,^ECKILL Q ;119 get data to export and stop processing.
- D GET
- D END
- Q
- GET ; start processing or records
- N DATE,ECL,ECNT,ECFN,ECEC,ECPX,ECSTR,ECD
- N NLOC,NDSSUNT,JJ ;152
- K ^TMP("ECNTPCE",$J)
- ;***152 Begins
- ;Set locations and dss units into ien subscripted arrays
- S JJ="" F S JJ=$O(ECLOC(JJ)) Q:JJ="" D
- .S NLOC($P(ECLOC(JJ),U,1))=$P(ECLOC(JJ),U,2)
- S JJ="" F S JJ=$O(ECDSSU(JJ)) Q:JJ="" D
- .S NDSSUNT($P(ECDSSU(JJ),U,1))=$P(ECDSSU(JJ),U,2)
- ;***152 Ends
- S DATE=ECSD,ECNT=0
- F S DATE=$O(^ECH("AC",DATE)) Q:('DATE)!(DATE>ECED) D
- .S ECFN=0 F S ECFN=$O(^ECH("AC",DATE,ECFN)) Q:'ECFN D
- ..Q:'$D(^ECH(ECFN,"R")) S ECEC=$G(^ECH(ECFN,0)) Q:ECEC=""
- ..S ECL=$P(ECEC,U,4),ECD=$P(ECEC,U,7),ECPX=$P(ECEC,U,9)
- ..S ECDFN=$P(ECEC,U,2)
- ..I (ECL="")!(ECD="")!(ECPX="")!(ECDFN="") Q
- ..I '$D(NLOC(ECL))!('$D(NDSSUNT(ECD))) Q ;152 - Not on Location or DSS Units selected list
- ..S ECSTR=ECFN_U_$P(ECEC,U,8)_U_ECPX
- ..S ECNT=ECNT+1,^TMP("ECNTPCE",$J,DATE,ECL,ECD,ECDFN,ECNT)=ECSTR
- ..K ECPRV S ECPRV=$$GETPRV^ECPRVMUT(ECFN,.ECPRV) I 'ECPRV D K ECPRV
- ...M ^TMP("ECNTPCE",$J,DATE,ECL,ECD,ECDFN,ECNT,"PRV")=ECPRV
- I $G(ECPTYP)="E" D PRT Q ;119
- D HDR
- I '$O(^TMP("ECNTPCE",$J,0)) D Q
- .W !!,?10,"No Data found during the time selected."
- D PRT
- Q
- ;
- END K ECSD,ECED
- I $D(ECGUI) D ^ECKILL Q
- W !
- I $E(IOST,1,2)="C-",$G(ECOUT)=0 W !!,"Press <RET> to continue" R X:DTIME
- ;W @IOF
- D ^%ZISC D ^ECKILL S:$D(ZTQUEUED) ZTREQ="@"
- Q
- PAGE ; end of page
- I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR I 'Y S ECOUT=1 Q
- I $O(^TMP("ECNTPCE",$J,ECDTE,ECL,ECD,ECDFN,ECNT))'="" D HDR ;152 to prevent printing just a header on the last page
- Q
- HDR ; print header
- W @IOF
- W ECRDT,?70,"Page: ",ECPG,!
- W !,?17,"ECS RECORDS FAILING TRANSMISSION TO PCE REPORT",!,?24
- W "FROM "_$P(ECDATE,U)_" TO "_$P(ECDATE,U,2),!!
- W "DATE/TIME",?16,"PATIENT",?39,"SSN",?44,"PROVIDER(S)",?61,"REASONS"
- W !,"LOCATION",?16,"PROCEDURE",!,"DSS UNIT",?16,"CATEGORY",!
- F LINE=1:1:80 W "-"
- W !
- S ECPG=ECPG+1
- Q
- ;
- PRT N ECLN,ECDN,ECPAT,ECEC,ECPS,ECDFN,ECUN,ECUN1,ECUN2,ECDTE,ECDT,ECRS,ECDE
- N ECX,ECAT,ECSSN,DFN,VA,VADM,ECEPN,ECECPT ;119
- S ECDTE=0 F S ECDTE=$O(^TMP("ECNTPCE",$J,ECDTE)) Q:'ECDTE D Q:ECOUT
- .S ECDT=$$FMTE^XLFDT(ECDTE,2),ECL=0
- .F S ECL=$O(^TMP("ECNTPCE",$J,ECDTE,ECL)) Q:'ECL D Q:ECOUT
- ..S ECLN=$P($G(^DIC(4,ECL,0)),U),ECLN=$S(ECLN="":"UNKNOWN",1:ECLN),ECD=0
- ..F S ECD=$O(^TMP("ECNTPCE",$J,ECDTE,ECL,ECD)) Q:'ECD D Q:ECOUT
- ...S ECDN=$P($G(^ECD(ECD,0)),U),ECDN=$S(ECDN="":"UNKNOWN",1:ECDN)
- ...S ECDFN=0
- ...F S ECDFN=$O(^TMP("ECNTPCE",$J,ECDTE,ECL,ECD,ECDFN)) Q:'ECDFN D Q:ECOUT
- ....S DFN=ECDFN D DEM^VADPT
- ....S ECPAT=VADM(1),ECSSN=$P($P(VADM(2),U,2),"-",3),ECNT=0
- ....F S ECNT=$O(^TMP("ECNTPCE",$J,ECDTE,ECL,ECD,ECDFN,ECNT)) Q:'ECNT D PR2 Q:ECOUT
- Q
- ;
- PR2 S ECEC=$G(^TMP("ECNTPCE",$J,ECDTE,ECL,ECD,ECDFN,ECNT))
- S ECPS="",ECFN=$P(ECEC,U)
- D PROV
- S ECAT=$S($P(ECEC,U,2):$P($G(^EC(726,$P(ECEC,U,2),0)),U),1:"")
- I $P(ECEC,U,3)'="" S ECDE=+$P(ECEC,U,3) D
- .I $P(ECEC,U,3)[";EC" D Q
- ..S ECPS=$G(^EC(725,+ECDE,0)),ECEPN=$P(ECPS,U),ECECPT=$P(ECPS,U,2),ECPS=$P(ECPS,U,2)_" "_$P(ECPS,U) ;119
- .S ECPS=$$CPT^ICPTCOD(ECDE,ECDTE),ECEPN=$S(+ECPS:$P(ECPS,U,3),1:"CPT NAME UNKNOWN"),ECECPT=$P(ECPS,U,2) ;119
- .S ECPS=$S(+ECPS>0:$P(ECPS,U,2)_" "_$P(ECPS,U,3),1:"CPT NAME UNKNOWN")
- S ECRS=^ECH(ECFN,"R")
- I $G(ECPTYP)="E" D EXPORT K ECPRV Q ;119
- W ECDT,?16,$E(ECPAT,1,20),?39,ECSSN,?44,$E(ECUN1,1,16),?61,$E($P(ECRS,";"),1,19),!
- W $E(ECLN,1,15),?16,$E(ECPS,1,27),?44,$E(ECUN2,1,16)
- W ?61,$E($P(ECRS,";",2),1,19),!
- W $E(ECDN,1,15),?16,$E(ECAT,1,27),?44,$E(ECUN3,1,16)
- W ?61,$E($P(ECRS,";",3),1,198)
- S ECUN=0 F ECX=4:1 S ECUN=$O(ECPRV(ECUN)) Q:(ECUN="")&($P(ECRS,";",ECX)="") D I ECOUT Q
- .W !
- .I ($Y+6)>IOSL D PAGE I ECOUT Q
- .I ECUN'="" W ?44,$E($P(ECPRV(ECUN),"^",2),1,16) K ECPRV(ECUN)
- .W ?61,$E($P(ECRS,";",ECX),1,19)
- W !!
- I ($Y+6)>IOSL D PAGE I ECOUT Q
- Q
- PROV ;Set provider 1-3 in variables
- M ECPRV=^TMP("ECNTPCE",$J,ECDTE,ECL,ECD,ECDFN,ECNT,"PRV")
- S ECUN=0,ECUN1="UNKNOWN",(ECUN2,ECUN3)=""
- F I=1:1:3 S ECUN=$O(ECPRV(ECUN)) Q:'ECUN D
- .S @("ECUN"_I)=$P(ECPRV(ECUN),"^",2) K ECPRV(ECUN)
- Q
- ;
- EXPORT ;Section added in patch 119
- N J
- S CNT=CNT+1
- S ^TMP($J,"ECRPT",CNT)=ECDT_U_ECLN_U_ECDN_U_ECAT_U_ECPAT_U_ECSSN_U_ECECPT_U_ECEPN_U_ECUN1_U_ECUN2_U_ECUN3
- F J=4:1:7 S ^TMP($J,"ECRPT",CNT)=^TMP($J,"ECRPT",CNT)_U_$P($G(ECPRV(J)),U,2) ;Set providers 4 through 7
- F J=1:1:3 S ^TMP($J,"ECRPT",CNT)=^TMP($J,"ECRPT",CNT)_U_$P(ECRS,";",J) ;add up to 3 reasons
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECNTPCE 5771 printed Mar 13, 2025@21:02:36 Page 2
- ECNTPCE ;ALB/JAM-Event Capture Records failing transmission to PCE;Sep 24, 2020@14:55:55
- +1 ;;2.0;EVENT CAPTURE;**61,72,119,152**;8 May 96;Build 19
- EN ; entry point
- +1 KILL %DT
- SET %DT="AEX"
- SET %DT("A")="Start with Date: "
- DO ^%DT
- IF Y<0
- GOTO END
- +2 SET ECSD=Y
- SET %DT("A")="End with Date: "
- DO ^%DT
- if Y<0
- GOTO END
- SET ECED=Y
- +3 IF ECED<ECSD
- WRITE !,"End date must be after start date",!
- GOTO EN
- +4 SET ECDATE=$$FMTE^XLFDT(ECSD)_U_$$FMTE^XLFDT(ECED)
- +5 SET ECSD=ECSD-.0001
- SET ECED=ECED+.9999
- +6 KILL IOP,%ZIS,POP,IO("Q")
- SET %ZIS("A")="Select Device: "
- SET %ZIS="QM"
- +7 DO ^%ZIS
- if POP
- GOTO END
- +8 IF $DATA(IO("Q"))
- KILL IO("Q")
- Begin DoDot:1
- +9 SET (ZTSAVE("ECDFN"),ZTSAVE("ECDATE"),ZTSAVE("ECED"),ZTSAVE("ECSD"))=""
- +10 SET ZTDESC="ECS RECORDS FAILING TRANSMISSION TO PCE REPORT"
- SET ZTRTN="START^ECNTPCE"
- +11 SET ZTIO=ION
- DO ^%ZTLOAD
- DO HOME^%ZIS
- End DoDot:1
- GOTO END
- +12 WRITE !,?5,"Please be patient, this may take a few moments..."
- +13 ;
- START ; entry when queued
- +1 ;119
- NEW ECOUT,X,Y,DIR,LINE,ECPG,ECRDT,%H,CNT
- +2 SET ECOUT=0
- SET ECPG=1
- +3 SET %H=$HOROLOG
- DO YX^%DTC
- SET ECRDT=Y
- +4 USE IO
- +5 ;119
- IF $GET(ECPTYP)="E"
- SET CNT=1
- SET ^TMP($JOB,"ECRPT",CNT)="DATE/TIME^LOCATION^DSS UNIT^CATEGORY^PATIENT^SSN^PROCEDURE CODE^PROCEDURE NAME^PROV 1^PROV 2^PROV 3^PROV 4^PROV 5^PROV 6^PROV 7^REASON 1^REASON 2^REASON 3"
- +6 ;119 get data to export and stop processing.
- IF $GET(ECPTYP)="E"
- DO GET
- DO ^ECKILL
- QUIT
- +7 DO GET
- +8 DO END
- +9 QUIT
- GET ; start processing or records
- +1 NEW DATE,ECL,ECNT,ECFN,ECEC,ECPX,ECSTR,ECD
- +2 ;152
- NEW NLOC,NDSSUNT,JJ
- +3 KILL ^TMP("ECNTPCE",$JOB)
- +4 ;***152 Begins
- +5 ;Set locations and dss units into ien subscripted arrays
- +6 SET JJ=""
- FOR
- SET JJ=$ORDER(ECLOC(JJ))
- if JJ=""
- QUIT
- Begin DoDot:1
- +7 SET NLOC($PIECE(ECLOC(JJ),U,1))=$PIECE(ECLOC(JJ),U,2)
- End DoDot:1
- +8 SET JJ=""
- FOR
- SET JJ=$ORDER(ECDSSU(JJ))
- if JJ=""
- QUIT
- Begin DoDot:1
- +9 SET NDSSUNT($PIECE(ECDSSU(JJ),U,1))=$PIECE(ECDSSU(JJ),U,2)
- End DoDot:1
- +10 ;***152 Ends
- +11 SET DATE=ECSD
- SET ECNT=0
- +12 FOR
- SET DATE=$ORDER(^ECH("AC",DATE))
- if ('DATE)!(DATE>ECED)
- QUIT
- Begin DoDot:1
- +13 SET ECFN=0
- FOR
- SET ECFN=$ORDER(^ECH("AC",DATE,ECFN))
- if 'ECFN
- QUIT
- Begin DoDot:2
- +14 if '$DATA(^ECH(ECFN,"R"))
- QUIT
- SET ECEC=$GET(^ECH(ECFN,0))
- if ECEC=""
- QUIT
- +15 SET ECL=$PIECE(ECEC,U,4)
- SET ECD=$PIECE(ECEC,U,7)
- SET ECPX=$PIECE(ECEC,U,9)
- +16 SET ECDFN=$PIECE(ECEC,U,2)
- +17 IF (ECL="")!(ECD="")!(ECPX="")!(ECDFN="")
- QUIT
- +18 ;152 - Not on Location or DSS Units selected list
- IF '$DATA(NLOC(ECL))!('$DATA(NDSSUNT(ECD)))
- QUIT
- +19 SET ECSTR=ECFN_U_$PIECE(ECEC,U,8)_U_ECPX
- +20 SET ECNT=ECNT+1
- SET ^TMP("ECNTPCE",$JOB,DATE,ECL,ECD,ECDFN,ECNT)=ECSTR
- +21 KILL ECPRV
- SET ECPRV=$$GETPRV^ECPRVMUT(ECFN,.ECPRV)
- IF 'ECPRV
- Begin DoDot:3
- +22 MERGE ^TMP("ECNTPCE",$JOB,DATE,ECL,ECD,ECDFN,ECNT,"PRV")=ECPRV
- End DoDot:3
- KILL ECPRV
- End DoDot:2
- End DoDot:1
- +23 ;119
- IF $GET(ECPTYP)="E"
- DO PRT
- QUIT
- +24 DO HDR
- +25 IF '$ORDER(^TMP("ECNTPCE",$JOB,0))
- Begin DoDot:1
- +26 WRITE !!,?10,"No Data found during the time selected."
- End DoDot:1
- QUIT
- +27 DO PRT
- +28 QUIT
- +29 ;
- END KILL ECSD,ECED
- +1 IF $DATA(ECGUI)
- DO ^ECKILL
- QUIT
- +2 WRITE !
- +3 IF $EXTRACT(IOST,1,2)="C-"
- IF $GET(ECOUT)=0
- WRITE !!,"Press <RET> to continue"
- READ X:DTIME
- +4 ;W @IOF
- +5 DO ^%ZISC
- DO ^ECKILL
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +6 QUIT
- PAGE ; end of page
- +1 IF $EXTRACT(IOST,1,2)="C-"
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET ECOUT=1
- QUIT
- +2 ;152 to prevent printing just a header on the last page
- IF $ORDER(^TMP("ECNTPCE",$JOB,ECDTE,ECL,ECD,ECDFN,ECNT))'=""
- DO HDR
- +3 QUIT
- HDR ; print header
- +1 WRITE @IOF
- +2 WRITE ECRDT,?70,"Page: ",ECPG,!
- +3 WRITE !,?17,"ECS RECORDS FAILING TRANSMISSION TO PCE REPORT",!,?24
- +4 WRITE "FROM "_$PIECE(ECDATE,U)_" TO "_$PIECE(ECDATE,U,2),!!
- +5 WRITE "DATE/TIME",?16,"PATIENT",?39,"SSN",?44,"PROVIDER(S)",?61,"REASONS"
- +6 WRITE !,"LOCATION",?16,"PROCEDURE",!,"DSS UNIT",?16,"CATEGORY",!
- +7 FOR LINE=1:1:80
- WRITE "-"
- +8 WRITE !
- +9 SET ECPG=ECPG+1
- +10 QUIT
- +11 ;
- PRT NEW ECLN,ECDN,ECPAT,ECEC,ECPS,ECDFN,ECUN,ECUN1,ECUN2,ECDTE,ECDT,ECRS,ECDE
- +1 ;119
- NEW ECX,ECAT,ECSSN,DFN,VA,VADM,ECEPN,ECECPT
- +2 SET ECDTE=0
- FOR
- SET ECDTE=$ORDER(^TMP("ECNTPCE",$JOB,ECDTE))
- if 'ECDTE
- QUIT
- Begin DoDot:1
- +3 SET ECDT=$$FMTE^XLFDT(ECDTE,2)
- SET ECL=0
- +4 FOR
- SET ECL=$ORDER(^TMP("ECNTPCE",$JOB,ECDTE,ECL))
- if 'ECL
- QUIT
- Begin DoDot:2
- +5 SET ECLN=$PIECE($GET(^DIC(4,ECL,0)),U)
- SET ECLN=$SELECT(ECLN="":"UNKNOWN",1:ECLN)
- SET ECD=0
- +6 FOR
- SET ECD=$ORDER(^TMP("ECNTPCE",$JOB,ECDTE,ECL,ECD))
- if 'ECD
- QUIT
- Begin DoDot:3
- +7 SET ECDN=$PIECE($GET(^ECD(ECD,0)),U)
- SET ECDN=$SELECT(ECDN="":"UNKNOWN",1:ECDN)
- +8 SET ECDFN=0
- +9 FOR
- SET ECDFN=$ORDER(^TMP("ECNTPCE",$JOB,ECDTE,ECL,ECD,ECDFN))
- if 'ECDFN
- QUIT
- Begin DoDot:4
- +10 SET DFN=ECDFN
- DO DEM^VADPT
- +11 SET ECPAT=VADM(1)
- SET ECSSN=$PIECE($PIECE(VADM(2),U,2),"-",3)
- SET ECNT=0
- +12 FOR
- SET ECNT=$ORDER(^TMP("ECNTPCE",$JOB,ECDTE,ECL,ECD,ECDFN,ECNT))
- if 'ECNT
- QUIT
- DO PR2
- if ECOUT
- QUIT
- End DoDot:4
- if ECOUT
- QUIT
- End DoDot:3
- if ECOUT
- QUIT
- End DoDot:2
- if ECOUT
- QUIT
- End DoDot:1
- if ECOUT
- QUIT
- +13 QUIT
- +14 ;
- PR2 SET ECEC=$GET(^TMP("ECNTPCE",$JOB,ECDTE,ECL,ECD,ECDFN,ECNT))
- +1 SET ECPS=""
- SET ECFN=$PIECE(ECEC,U)
- +2 DO PROV
- +3 SET ECAT=$SELECT($PIECE(ECEC,U,2):$PIECE($GET(^EC(726,$PIECE(ECEC,U,2),0)),U),1:"")
- +4 IF $PIECE(ECEC,U,3)'=""
- SET ECDE=+$PIECE(ECEC,U,3)
- Begin DoDot:1
- +5 IF $PIECE(ECEC,U,3)[";EC"
- Begin DoDot:2
- +6 ;119
- SET ECPS=$GET(^EC(725,+ECDE,0))
- SET ECEPN=$PIECE(ECPS,U)
- SET ECECPT=$PIECE(ECPS,U,2)
- SET ECPS=$PIECE(ECPS,U,2)_" "_$PIECE(ECPS,U)
- End DoDot:2
- QUIT
- +7 ;119
- SET ECPS=$$CPT^ICPTCOD(ECDE,ECDTE)
- SET ECEPN=$SELECT(+ECPS:$PIECE(ECPS,U,3),1:"CPT NAME UNKNOWN")
- SET ECECPT=$PIECE(ECPS,U,2)
- +8 SET ECPS=$SELECT(+ECPS>0:$PIECE(ECPS,U,2)_" "_$PIECE(ECPS,U,3),1:"CPT NAME UNKNOWN")
- End DoDot:1
- +9 SET ECRS=^ECH(ECFN,"R")
- +10 ;119
- IF $GET(ECPTYP)="E"
- DO EXPORT
- KILL ECPRV
- QUIT
- +11 WRITE ECDT,?16,$EXTRACT(ECPAT,1,20),?39,ECSSN,?44,$EXTRACT(ECUN1,1,16),?61,$EXTRACT($PIECE(ECRS,";"),1,19),!
- +12 WRITE $EXTRACT(ECLN,1,15),?16,$EXTRACT(ECPS,1,27),?44,$EXTRACT(ECUN2,1,16)
- +13 WRITE ?61,$EXTRACT($PIECE(ECRS,";",2),1,19),!
- +14 WRITE $EXTRACT(ECDN,1,15),?16,$EXTRACT(ECAT,1,27),?44,$EXTRACT(ECUN3,1,16)
- +15 WRITE ?61,$EXTRACT($PIECE(ECRS,";",3),1,198)
- +16 SET ECUN=0
- FOR ECX=4:1
- SET ECUN=$ORDER(ECPRV(ECUN))
- if (ECUN="")&($PIECE(ECRS,";",ECX)="")
- QUIT
- Begin DoDot:1
- +17 WRITE !
- +18 IF ($Y+6)>IOSL
- DO PAGE
- IF ECOUT
- QUIT
- +19 IF ECUN'=""
- WRITE ?44,$EXTRACT($PIECE(ECPRV(ECUN),"^",2),1,16)
- KILL ECPRV(ECUN)
- +20 WRITE ?61,$EXTRACT($PIECE(ECRS,";",ECX),1,19)
- End DoDot:1
- IF ECOUT
- QUIT
- +21 WRITE !!
- +22 IF ($Y+6)>IOSL
- DO PAGE
- IF ECOUT
- QUIT
- +23 QUIT
- PROV ;Set provider 1-3 in variables
- +1 MERGE ECPRV=^TMP("ECNTPCE",$JOB,ECDTE,ECL,ECD,ECDFN,ECNT,"PRV")
- +2 SET ECUN=0
- SET ECUN1="UNKNOWN"
- SET (ECUN2,ECUN3)=""
- +3 FOR I=1:1:3
- SET ECUN=$ORDER(ECPRV(ECUN))
- if 'ECUN
- QUIT
- Begin DoDot:1
- +4 SET @("ECUN"_I)=$PIECE(ECPRV(ECUN),"^",2)
- KILL ECPRV(ECUN)
- End DoDot:1
- +5 QUIT
- +6 ;
- EXPORT ;Section added in patch 119
- +1 NEW J
- +2 SET CNT=CNT+1
- +3 SET ^TMP($JOB,"ECRPT",CNT)=ECDT_U_ECLN_U_ECDN_U_ECAT_U_ECPAT_U_ECSSN_U_ECECPT_U_ECEPN_U_ECUN1_U_ECUN2_U_ECUN3
- +4 ;Set providers 4 through 7
- FOR J=4:1:7
- SET ^TMP($JOB,"ECRPT",CNT)=^TMP($JOB,"ECRPT",CNT)_U_$PIECE($GET(ECPRV(J)),U,2)
- +5 ;add up to 3 reasons
- FOR J=1:1:3
- SET ^TMP($JOB,"ECRPT",CNT)=^TMP($JOB,"ECRPT",CNT)_U_$PIECE(ECRS,";",J)
- +6 QUIT
