ECXSETUP ;ALB/JAP,BIR/DMA,CML,PTD-Generate Patient Population for a Given Day ;3/17/17 13:12
;;3.0;DSS EXTRACTS;**11,8,24,166**;Dec 22, 1997;Build 24
EN ;entry point from option
;Pick a day, find everyone who was in the hospital on that day,
;find the corresponding admission and the last transfer and treating
;speciality change
;This routine should only be run once
I '$D(DT) S DT=$$HTFM^XLFDT(+$H)
I $P($G(^ECX(728,1,"S")),U,2)]"" W !,"The setup extract is already running.",! Q
I $P($G(^ECX(728,1,"S")),U) W !,"The setup extract has already been run.",! Q
W !!,"This option will extract the admission data and data for the last",!,"transfer and treating specialty change for all patients who",!,"were in the hospital on the day you select.",!!
W !!,"NOTE - This will generate a snapshot of your inpatient population on the",!,"BEGINNING of the day you select, not the end of the day as MAS/HAS reports do.",!
W "For example, for the inpatient setup extract if you choose October 1, 1994,",!,"the report will start at midnight at the beginning of the day."
W " For the MAS/HAS",!,"report, you would choose September 30, 1994. The MAS/HAS report begins at",!,"midnight at the end of the day.",!!!
S Y=$E(DT,1,3) S:'$E(DT,4) Y=Y-1 S ECDEX=$$FMTE^XLFDT(Y_"1001")
DATE S DIR(0)="D^::EXP",DIR("A")="Select the starting date ",DIR("B")=ECDEX D ^DIR K DIR G END:$D(DIRUT) S ECED=Y I Y>DT W !,"Date must be in the past",! G DATE
S ECDEX=$$FMTE^XLFDT(Y)
S ZTSAVE("ECED")="",ZTDESC="Find all inpatients on "_ECDEX,ZTIO="",ZTRTN="START^ECXSETUP" D ^%ZTLOAD
I $D(ZTSK) W !,"Request queued as Task #",ZTSK,".",!
G END
;
START ;queued entry point
I $G(^ECX(728,1,"S"))]"",$G(^("S"))'="^" Q ;already running or finished
S $P(^ECX(728,1,"S"),U,2)="R" ; set run flag
K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
S ECPACK="Admission setup",ECPIECE=13,ECRTN="START^ECXSETUP",ECGRP="ADMS",ECHEAD="ADM",ECFILE=727.82,ECSD=ECED,ECD=ECED,ECVER=7
S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
S ECRN=0,QFLG=0
S ECD0=9999999.9999999-ECD
K ^TMP($J)
F DFN=0:0 S DFN=$O(^DGPM("ATID1",DFN)) Q:'DFN S EC1=$O(^(DFN,ECD0)) I EC1 S ECDA=+$O(^(EC1,0)) I $D(^DGPM(ECDA,0)) D Q:QFLG
.S EC=^(0),ECX=+$P(EC,U,17),ECAS=$P(EC,U,18)=40 D:$S('ECX:1,'$D(^DGPM(ECX,0)):1,^DGPM(ECX,0)>ECD:1,1:0) GET I ECAS D GET1
I QFLG S ZTSTOP=1 G END
S ECLAST=$O(^ECX(ECFILE,999999999),-1),ECTOTAL=$P(^ECX(ECFILE,0),U,4)+ECRN,$P(^(0),U,3,4)=ECLAST_U_ECTOTAL K ECLAST,ECTOTAL
G ^ECXSETU1
END K DIR,ECD,ECDEX,X,Y,ECD0,DFN,DA,EC0
Q
;
GET ;
Q:'$D(^DPT(DFN,0))
S D0=^DPT(DFN,0)
Q:$E($P(D0,U,9),1,5)="00000"
S ECAD=$P(EC,U),^TMP($J,DFN,ECDA)=""
S ECTM=$$ECXTIME^ECXUTL(ECAD),ECXYM=$$ECXYM^ECXUTL(ECED)
S X=$$PRIMARY^ECXUTL2(DFN,ECD),ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2)
S ECODE=DFN_U_$P(D0,U,9)_U_$E($P($P(D0,U),",")_" ",1,4)_"^3^"_$$ECXDATE^ECXUTL(ECAD,ECXYM)_U_ECPTTM
S ECODE=ECODE_U_$P(D0,U,2)_U_$$ECXDOB^ECXUTL($P(D0,U,3))_U_$P(D0,U,8)_U_$P($G(^DPT(DFN,.311)),U,15)_U_+$$INSURED^IBCNS1(DFN,ECD)
S D1=$G(^DPT(DFN,.11)),ECSTA=$P(D1,U,5),STATE=$S(ECSTA:$P(^DIC(5,ECSTA,0),U,3),1:"")
S ECCTY=$P(D1,U,7),COUNTY=$S(ECCTY:$P(^DIC(5,ECSTA,1,ECCTY,0),U,3),1:"")
S ECODE=ECODE_U_STATE_U_COUNTY_U_$P(D1,U,6),D1=$P($G(^DIC(8,+$G(^DPT(DFN,.36)),0)),U,9) I D1 S D1=$C(D1+64)
S ECM=$P($G(^DG(408.32,+$P(D0,U,14),0)),U,2)
S ECODE=ECODE_U_D1_U_$P($G(^DPT(DFN,"VET")),U)_U_$P($G(^DPT(DFN,.321))_"^^^^",U,1,3)_U_$P($G(^DPT(DFN,.52)),U,5)_U_$P($G(^DIC(21,+$P($G(^DPT(DFN,.32)),U,3),0)),U,3)_U_ECM_U_$P(D0,U,5)
S W=$P(EC,U,6),FAC=$P($G(^DIC(42,+W,0)),U,11),W=$P($G(^DIC(42,+W,44)),U)
S ECTS="" F J=1:1:100 S ECT1=$G(^DGPM(ECDA+J,0)) I $P(ECT1,U,14)=ECDA,$P(ECT1,U,2)=6 S ECTS=ECT1 Q
;get corresponding Treating specialty - should be the next one, but must be close
S ECODE=FAC_U_ECODE_U_W_U_$P($G(^DIC(45.7,+$P(ECTS,U,9),0)),U,2)_U_ECPRO_$P(ECTS,U,19)_U_ECDA
S (ECDRG,ECDIA)="",ECPTF=+$P(EC,U,16) I ECPTF,$D(^DGPT(ECPTF,"M")) D PTF S ECODE=ECODE_U_ECDRG_U_ECDIA
S $P(ECODE,U,31)=ECTM,$P(ECODE,U,32)=ECPTPR,$P(ECODE,U,33)=$P($G(^DIC(10,+$P(D0,U,6),0)),U,2)_"^"
;facility^dfn^ssn^name^in/out^day^primary care team^sex^dob^religion^employment status^health ins^state^county^zip^eligibility^
;vet^vietnam^agent orange^radiation^pow^period of service^means test^marital status^ward^treating specialty^
;attending physician^mov #^DRG^diagnosis^time^primary care provider^race
FILE ;file record
S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
S ^ECX(ECFILE,EC7,0)=EC7_U_ECXYM_U_U_ECODE,ECRN=ECRN+1
S $P(^ECX(ECFILE,EC7,1),U,12)=""
S DA=EC7,DIK="^ECX("_ECFILE_"," D IX^DIK K DIK,DA
I $D(ZTQUEUED),ECRN>499,'(ECRN#500),$$S^%ZTLOAD S QFLG=1
Q
;
GET1 ;look again for admission if the one we found was ASIH (ECAS=1)
F EC1=EC1:0 S EC1=$O(^DGPM("ATID1",DFN,EC1)) Q:'EC1 S ECDA=$O(^(EC1,0)) I ECDA,$D(^DGPM(ECDA,0)) S EC=^DGPM(ECDA,0) I $P(EC,U,18)'=40 S ECX=$P(EC,U,17) Q
I EC1,ECDA,$S('ECX:1,'$D(^DGPM(ECX,0)):1,^DGPM(ECX,0)>ECD:1,1:0) D GET ; find the admission movement (not ASIH) for this ASIH movement
Q
;
;
PTF ; get admitting DRG and diagnosis from PTF
;use number for DRG and .01 for diagnosis
S EC=1 I $D(^DGPT(ECPTF,"M",2,0)) S EC=2
S EC2=+$P(^DGPT(ECPTF,"M",EC,0),U,5),ECDRG=$P($G(^DGPT(ECPTF,"M",EC,"P")),U)
S ECDIA=$P($G(^ICD9(EC2,0)),U) Q
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXSETUP 5503 printed Nov 22, 2024@17:04:08 Page 2
ECXSETUP ;ALB/JAP,BIR/DMA,CML,PTD-Generate Patient Population for a Given Day ;3/17/17 13:12
+1 ;;3.0;DSS EXTRACTS;**11,8,24,166**;Dec 22, 1997;Build 24
EN ;entry point from option
+1 ;Pick a day, find everyone who was in the hospital on that day,
+2 ;find the corresponding admission and the last transfer and treating
+3 ;speciality change
+4 ;This routine should only be run once
+5 IF '$DATA(DT)
SET DT=$$HTFM^XLFDT(+$HOROLOG)
+6 IF $PIECE($GET(^ECX(728,1,"S")),U,2)]""
WRITE !,"The setup extract is already running.",!
QUIT
+7 IF $PIECE($GET(^ECX(728,1,"S")),U)
WRITE !,"The setup extract has already been run.",!
QUIT
+8 WRITE !!,"This option will extract the admission data and data for the last",!,"transfer and treating specialty change for all patients who",!,"were in the hospital on the day you select.",!!
+9 WRITE !!,"NOTE - This will generate a snapshot of your inpatient population on the",!,"BEGINNING of the day you select, not the end of the day as MAS/HAS reports do.",!
+10 WRITE "For example, for the inpatient setup extract if you choose October 1, 1994,",!,"the report will start at midnight at the beginning of the day."
+11 WRITE " For the MAS/HAS",!,"report, you would choose September 30, 1994. The MAS/HAS report begins at",!,"midnight at the end of the day.",!!!
+12 SET Y=$EXTRACT(DT,1,3)
if '$EXTRACT(DT,4)
SET Y=Y-1
SET ECDEX=$$FMTE^XLFDT(Y_"1001")
DATE SET DIR(0)="D^::EXP"
SET DIR("A")="Select the starting date "
SET DIR("B")=ECDEX
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET ECED=Y
IF Y>DT
WRITE !,"Date must be in the past",!
GOTO DATE
+1 SET ECDEX=$$FMTE^XLFDT(Y)
+2 SET ZTSAVE("ECED")=""
SET ZTDESC="Find all inpatients on "_ECDEX
SET ZTIO=""
SET ZTRTN="START^ECXSETUP"
DO ^%ZTLOAD
+3 IF $DATA(ZTSK)
WRITE !,"Request queued as Task #",ZTSK,".",!
+4 GOTO END
+5 ;
START ;queued entry point
+1 ;already running or finished
IF $GET(^ECX(728,1,"S"))]""
IF $GET(^("S"))'="^"
QUIT
+2 ; set run flag
SET $PIECE(^ECX(728,1,"S"),U,2)="R"
+3 KILL ECXDD
DO FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
SET ECPRO=$EXTRACT(+$PIECE(ECXDD("SPECIFIER"),"P",2))
KILL ECXDD
+4 SET ECPACK="Admission setup"
SET ECPIECE=13
SET ECRTN="START^ECXSETUP"
SET ECGRP="ADMS"
SET ECHEAD="ADM"
SET ECFILE=727.82
SET ECSD=ECED
SET ECD=ECED
SET ECVER=7
+5 SET ECINST=+$PIECE(^ECX(728,1,0),U)
KILL ECXDIC
SET DA=ECINST
SET DIC="^DIC(4,"
SET DIQ(0)="I"
SET DIQ="ECXDIC"
SET DR=".01;99"
+6 DO EN^DIQ1
SET ECINST=$GET(ECXDIC(4,DA,99,"I"))
KILL DIC,DIQ,DA,DR,ECXDIC
+7 SET ECRN=0
SET QFLG=0
+8 SET ECD0=9999999.9999999-ECD
+9 KILL ^TMP($JOB)
+10 FOR DFN=0:0
SET DFN=$ORDER(^DGPM("ATID1",DFN))
if 'DFN
QUIT
SET EC1=$ORDER(^(DFN,ECD0))
IF EC1
SET ECDA=+$ORDER(^(EC1,0))
IF $DATA(^DGPM(ECDA,0))
Begin DoDot:1
+11 SET EC=^(0)
SET ECX=+$PIECE(EC,U,17)
SET ECAS=$PIECE(EC,U,18)=40
if $SELECT('ECX
DO GET
IF ECAS
DO GET1
End DoDot:1
if QFLG
QUIT
+12 IF QFLG
SET ZTSTOP=1
GOTO END
+13 SET ECLAST=$ORDER(^ECX(ECFILE,999999999),-1)
SET ECTOTAL=$PIECE(^ECX(ECFILE,0),U,4)+ECRN
SET $PIECE(^(0),U,3,4)=ECLAST_U_ECTOTAL
KILL ECLAST,ECTOTAL
+14 GOTO ^ECXSETU1
END KILL DIR,ECD,ECDEX,X,Y,ECD0,DFN,DA,EC0
+1 QUIT
+2 ;
GET ;
+1 if '$DATA(^DPT(DFN,0))
QUIT
+2 SET D0=^DPT(DFN,0)
+3 if $EXTRACT($PIECE(D0,U,9),1,5)="00000"
QUIT
+4 SET ECAD=$PIECE(EC,U)
SET ^TMP($JOB,DFN,ECDA)=""
+5 SET ECTM=$$ECXTIME^ECXUTL(ECAD)
SET ECXYM=$$ECXYM^ECXUTL(ECED)
+6 SET X=$$PRIMARY^ECXUTL2(DFN,ECD)
SET ECPTTM=$PIECE(X,U,1)
SET ECPTPR=$PIECE(X,U,2)
+7 SET ECODE=DFN_U_$PIECE(D0,U,9)_U_$EXTRACT($PIECE($PIECE(D0,U),",")_" ",1,4)_"^3^"_$$ECXDATE^ECXUTL(ECAD,ECXYM)_U_ECPTTM
+8 SET ECODE=ECODE_U_$PIECE(D0,U,2)_U_$$ECXDOB^ECXUTL($PIECE(D0,U,3))_U_$PIECE(D0,U,8)_U_$PIECE($GET(^DPT(DFN,.311)),U,15)_U_+$$INSURED^IBCNS1(DFN,ECD)
+9 SET D1=$GET(^DPT(DFN,.11))
SET ECSTA=$PIECE(D1,U,5)
SET STATE=$SELECT(ECSTA:$PIECE(^DIC(5,ECSTA,0),U,3),1:"")
+10 SET ECCTY=$PIECE(D1,U,7)
SET COUNTY=$SELECT(ECCTY:$PIECE(^DIC(5,ECSTA,1,ECCTY,0),U,3),1:"")
+11 SET ECODE=ECODE_U_STATE_U_COUNTY_U_$PIECE(D1,U,6)
SET D1=$PIECE($GET(^DIC(8,+$GET(^DPT(DFN,.36)),0)),U,9)
IF D1
SET D1=$CHAR(D1+64)
+12 SET ECM=$PIECE($GET(^DG(408.32,+$PIECE(D0,U,14),0)),U,2)
+13 SET ECODE=ECODE_U_D1_U_$PIECE($GET(^DPT(DFN,"VET")),U)_U_$PIECE($GET(^DPT(DFN,.321))_"^^^^",U,1,3)_U_$PIECE($GET(^DPT(DFN,.52)),U,5)_U_$PIECE($GET(^DIC(21,+$PIECE($GET(^DPT(DFN,.32)),U,3),0)),U,3)_U_ECM_U_$PIECE(D0,U,5)
+14 SET W=$PIECE(EC,U,6)
SET FAC=$PIECE($GET(^DIC(42,+W,0)),U,11)
SET W=$PIECE($GET(^DIC(42,+W,44)),U)
+15 SET ECTS=""
FOR J=1:1:100
SET ECT1=$GET(^DGPM(ECDA+J,0))
IF $PIECE(ECT1,U,14)=ECDA
IF $PIECE(ECT1,U,2)=6
SET ECTS=ECT1
QUIT
+16 ;get corresponding Treating specialty - should be the next one, but must be close
+17 SET ECODE=FAC_U_ECODE_U_W_U_$PIECE($GET(^DIC(45.7,+$PIECE(ECTS,U,9),0)),U,2)_U_ECPRO_$PIECE(ECTS,U,19)_U_ECDA
+18 SET (ECDRG,ECDIA)=""
SET ECPTF=+$PIECE(EC,U,16)
IF ECPTF
IF $DATA(^DGPT(ECPTF,"M"))
DO PTF
SET ECODE=ECODE_U_ECDRG_U_ECDIA
+19 SET $PIECE(ECODE,U,31)=ECTM
SET $PIECE(ECODE,U,32)=ECPTPR
SET $PIECE(ECODE,U,33)=$PIECE($GET(^DIC(10,+$PIECE(D0,U,6),0)),U,2)_"^"
+20 ;facility^dfn^ssn^name^in/out^day^primary care team^sex^dob^religion^employment status^health ins^state^county^zip^eligibility^
+21 ;vet^vietnam^agent orange^radiation^pow^period of service^means test^marital status^ward^treating specialty^
+22 ;attending physician^mov #^DRG^diagnosis^time^primary care provider^race
FILE ;file record
+1 SET EC7=$ORDER(^ECX(ECFILE,999999999),-1)
SET EC7=EC7+1
+2 SET ^ECX(ECFILE,EC7,0)=EC7_U_ECXYM_U_U_ECODE
SET ECRN=ECRN+1
+3 SET $PIECE(^ECX(ECFILE,EC7,1),U,12)=""
+4 SET DA=EC7
SET DIK="^ECX("_ECFILE_","
DO IX^DIK
KILL DIK,DA
+5 IF $DATA(ZTQUEUED)
IF ECRN>499
IF '(ECRN#500)
IF $$S^%ZTLOAD
SET QFLG=1
+6 QUIT
+7 ;
GET1 ;look again for admission if the one we found was ASIH (ECAS=1)
+1 FOR EC1=EC1:0
SET EC1=$ORDER(^DGPM("ATID1",DFN,EC1))
if 'EC1
QUIT
SET ECDA=$ORDER(^(EC1,0))
IF ECDA
IF $DATA(^DGPM(ECDA,0))
SET EC=^DGPM(ECDA,0)
IF $PIECE(EC,U,18)'=40
SET ECX=$PIECE(EC,U,17)
QUIT
+2 ; find the admission movement (not ASIH) for this ASIH movement
IF EC1
IF ECDA
IF $SELECT('ECX:1,'$DATA(^DGPM(ECX,0)):1,^DGPM(ECX,0)>ECD:1,1:0)
DO GET
+3 QUIT
+4 ;
+5 ;
PTF ; get admitting DRG and diagnosis from PTF
+1 ;use number for DRG and .01 for diagnosis
+2 SET EC=1
IF $DATA(^DGPT(ECPTF,"M",2,0))
SET EC=2
+3 SET EC2=+$PIECE(^DGPT(ECPTF,"M",EC,0),U,5)
SET ECDRG=$PIECE($GET(^DGPT(ECPTF,"M",EC,"P")),U)
+4 SET ECDIA=$PIECE($GET(^ICD9(EC2,0)),U)
QUIT
+5 ;
+6 ;
