ECXPAI ;ALB/JAP,BIR/DMA,PTD-PAI Extract from File 45.9 ; 10/30/96 14:25
;;3.0;DSS EXTRACTS;**8,20,24,33**;Dec 22, 1997
BEG ;entry point from option
D SETUP I ECFILE="" Q
D ^ECXTRAC,^ECXKILL
Q
;
START ; start package specific extract
N OK
S QFLG=0
S ECED=ECED+.3,ECD=ECSD1
F S ECD=$O(^DG(45.9,"AA",ECD)),ECF=0 Q:'ECD Q:ECD>ECED Q:QFLG F S ECF=$O(^DG(45.9,"AA",ECD,ECF)) Q:'ECF I $D(^DG(45.9,ECF,0)) S EC=^(0),ECXDFN=+EC,ECTD=$P(EC,U,7) D Q:QFLG
.K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.ECXPAT)
.Q:'OK
.S X=$$INP^ECXUTL2(ECXDFN,$P(ECD,"."))
.S ECXA=$P(X,U),ECXDOM=$P(X,U,10),ECXPNM=ECXPAT("NAME")
.S ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI"),ECXRACE=ECXPAT("RACE")
.S ECXDSSD="",ECDA=0
.F S ECDA=+$O(^DGPM("APCA",ECXDFN,ECDA)),ECTD1=ECTD-.0001 Q:'ECDA I $D(^DGPM(ECDA,0)) F S ECTD1=+$O(^DGPM("APCA",ECXDFN,ECDA,ECTD1)) Q:'ECTD1 Q:ECTD1>(ECTD+.3) D Q:QFLG
..S EC1=0 F S EC1=+$O(^DGPM("APCA",ECXDFN,ECDA,ECTD1,EC1)) Q:'EC1 I $D(^DGPM(EC1,0)),$P(^(0),U,2)'=3 S ECADM=$P(^DGPM(ECDA,0),U) D Q:QFLG
...D FILE
Q
;
FILE ;file record
;^dfn^ssn^name^i/o (ECXA)^day^admission date^admission time^
;admission/transfer date^admission/transfer time^race
;node1
;mpi^dss dept^dom^extended out patient
N DA,DIK
S EC7=$O(^ECX(ECFILE,999999999),-1)
S ECODEZ="" I EC7>0 S ECODEZ=^ECX(ECFILE,EC7,0)
S ECODE=U_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_3_U
S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U
S ECODE=ECODE_$$ECXDATE^ECXUTL(ECADM,ECXYM)_U
S ECODE=ECODE_$$ECXTIME^ECXUTL(ECADM)_U_$$ECXDATE^ECXUTL(ECTD1,ECXYM)_U
S ECODE=ECODE_$$ECXTIME^ECXUTL(ECTD1)_U_ECXRACE_U
S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_$G(ECXEOP)
Q:$P(ECODE,U,4,14)=$P(ECODEZ,U,4,14)
I $P(ECODE,U,3,7)=$P(ECODEZ,U,5,9),$P(ECODE,U,10)=$P(ECODEZ,U,12),$P(ECODE,U,8,9)'=$P(ECODEZ,10,11) D Q
.S $P(^ECX(ECFILE,EC7,0),U,10,11)=$P(ECODE,U,8,9)
S EC7=EC7+1
S ^ECX(ECFILE,EC7,0)=EC7_U_EC23_ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
Q
;
SETUP ;Set required input for ECXTRAC
S ECHEAD="PAS"
D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
Q
;
QUE ; entry point for the background requeuing handled by ECXTAUTO
D SETUP,QUE^ECXTAUTO,^ECXKILL Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXPAI 2307 printed Apr 09, 2024@20:55:29 Page 2
ECXPAI ;ALB/JAP,BIR/DMA,PTD-PAI Extract from File 45.9 ; 10/30/96 14:25
+1 ;;3.0;DSS EXTRACTS;**8,20,24,33**;Dec 22, 1997
BEG ;entry point from option
+1 DO SETUP
IF ECFILE=""
QUIT
+2 DO ^ECXTRAC
DO ^ECXKILL
+3 QUIT
+4 ;
START ; start package specific extract
+1 NEW OK
+2 SET QFLG=0
+3 SET ECED=ECED+.3
SET ECD=ECSD1
+4 FOR
SET ECD=$ORDER(^DG(45.9,"AA",ECD))
SET ECF=0
if 'ECD
QUIT
if ECD>ECED
QUIT
if QFLG
QUIT
FOR
SET ECF=$ORDER(^DG(45.9,"AA",ECD,ECF))
if 'ECF
QUIT
IF $DATA(^DG(45.9,ECF,0))
SET EC=^(0)
SET ECXDFN=+EC
SET ECTD=$PIECE(EC,U,7)
Begin DoDot:1
+5 KILL ECXPAT
SET OK=$$PAT^ECXUTL3(ECXDFN,$PIECE(ECD,"."),"1;",.ECXPAT)
+6 if 'OK
QUIT
+7 SET X=$$INP^ECXUTL2(ECXDFN,$PIECE(ECD,"."))
+8 SET ECXA=$PIECE(X,U)
SET ECXDOM=$PIECE(X,U,10)
SET ECXPNM=ECXPAT("NAME")
+9 SET ECXSSN=ECXPAT("SSN")
SET ECXMPI=ECXPAT("MPI")
SET ECXRACE=ECXPAT("RACE")
+10 SET ECXDSSD=""
SET ECDA=0
+11 FOR
SET ECDA=+$ORDER(^DGPM("APCA",ECXDFN,ECDA))
SET ECTD1=ECTD-.0001
if 'ECDA
QUIT
IF $DATA(^DGPM(ECDA,0))
FOR
SET ECTD1=+$ORDER(^DGPM("APCA",ECXDFN,ECDA,ECTD1))
if 'ECTD1
QUIT
if ECTD1>(ECTD+.3)
QUIT
Begin DoDot:2
+12 SET EC1=0
FOR
SET EC1=+$ORDER(^DGPM("APCA",ECXDFN,ECDA,ECTD1,EC1))
if 'EC1
QUIT
IF $DATA(^DGPM(EC1,0))
IF $PIECE(^(0),U,2)'=3
SET ECADM=$PIECE(^DGPM(ECDA,0),U)
Begin DoDot:3
+13 DO FILE
End DoDot:3
if QFLG
QUIT
End DoDot:2
if QFLG
QUIT
End DoDot:1
if QFLG
QUIT
+14 QUIT
+15 ;
FILE ;file record
+1 ;^dfn^ssn^name^i/o (ECXA)^day^admission date^admission time^
+2 ;admission/transfer date^admission/transfer time^race
+3 ;node1
+4 ;mpi^dss dept^dom^extended out patient
+5 NEW DA,DIK
+6 SET EC7=$ORDER(^ECX(ECFILE,999999999),-1)
+7 SET ECODEZ=""
IF EC7>0
SET ECODEZ=^ECX(ECFILE,EC7,0)
+8 SET ECODE=U_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_3_U
+9 SET ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U
+10 SET ECODE=ECODE_$$ECXDATE^ECXUTL(ECADM,ECXYM)_U
+11 SET ECODE=ECODE_$$ECXTIME^ECXUTL(ECADM)_U_$$ECXDATE^ECXUTL(ECTD1,ECXYM)_U
+12 SET ECODE=ECODE_$$ECXTIME^ECXUTL(ECTD1)_U_ECXRACE_U
+13 SET ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_$GET(ECXEOP)
+14 if $PIECE(ECODE,U,4,14)=$PIECE(ECODEZ,U,4,14)
QUIT
+15 IF $PIECE(ECODE,U,3,7)=$PIECE(ECODEZ,U,5,9)
IF $PIECE(ECODE,U,10)=$PIECE(ECODEZ,U,12)
IF $PIECE(ECODE,U,8,9)'=$PIECE(ECODEZ,10,11)
Begin DoDot:1
+16 SET $PIECE(^ECX(ECFILE,EC7,0),U,10,11)=$PIECE(ECODE,U,8,9)
End DoDot:1
QUIT
+17 SET EC7=EC7+1
+18 SET ^ECX(ECFILE,EC7,0)=EC7_U_EC23_ECODE
SET ^ECX(ECFILE,EC7,1)=ECODE1
SET ECRN=ECRN+1
+19 SET DA=EC7
SET DIK="^ECX("_ECFILE_","
DO IX1^DIK
KILL DIK,DA
+20 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET QFLG=1
+21 QUIT
+22 ;
SETUP ;Set required input for ECXTRAC
+1 SET ECHEAD="PAS"
+2 DO ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+3 QUIT
+4 ;
QUE ; entry point for the background requeuing handled by ECXTAUTO
+1 DO SETUP
DO QUE^ECXTAUTO
DO ^ECXKILL
QUIT
