- 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 Mar 13, 2025@20:58 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
