ECXSETU1 ;BIR/DMA,CML,PTD-Get Movements and Treating Speciality for Setup ; [ 01/10/97 4:34 PM ]
;;3.0;DSS EXTRACTS;**8,24**;Dec 22, 1997
EN ;entry point
;get movements
S ECFILE=727.821,ECRN=0,QFLG=0
F DFN=0:0 S DFN=$O(^TMP($J,DFN)) Q:'DFN F ECCA=0:0 S ECCA=$O(^TMP($J,DFN,ECCA)) Q:'ECCA S ECM=$O(^DGPM("APMV",DFN,ECCA,ECD0)) I ECM S ECDA=$O(^(ECM,0)) I ECDA,ECDA'=ECCA,$D(^DGPM(+ECDA,0)) S EC=^(0),DFN=+$P(EC,U,3) D Q:QFLG
.Q:'$D(^DPT(DFN,0)) S D0=^DPT(DFN,0),ECDAT=ECED,ECTM=$E($P(ECDAT,".",2)_"000000",1,6),ECXYM=$$ECXYM^ECXUTL(ECDAT),ECMT=$P(EC,U,18),ECMT=$S(ECMT<22:ECMT,ECMT<25:4,ECMT=25:3,ECMT=26:2,1:ECMT)
.;from absence becomes transfer, from auth to unauth becomes to unauth
.;from unauth to auth becomes to auth
.S WTO=$P(EC,U,6),WTO=$P($G(^DIC(42,+WTO,44)),U)
.S ECCA=$P(EC,U,14),EC=^DGPM(ECCA,0),ECA=$E($P(EC,U),".")
.;use admit as previous transfer
.S W=$P(EC,U,6),FAC=$P($G(^DIC(42,+W,0)),U,11),W=$P($G(^DIC(42,+W,44)),U)
.S ECODE=FAC_U_DFN_U_$P(D0,U,9)_U_$E($P($P(D0,U),",")_" ",1,4)_"^3^"_$$ECXDATE^ECXUTL(ECD,ECXYM)_U
.S ECA=$P($G(^DGPM(+$P(EC,U,14),0)),U)
.S X1=ECD,X2=$P(EC,U) D ^%DTC S LOS=X
.S ECODE=ECODE_U_$$ECXDATE^ECXUTL(ECA,ECXYM)_"^^"_ECDA_"^2^"_W_"^^"_LOS_"^^"_ECMT_U_ECTM_U_WTO_U_$$ECXTIME^ECXUTL(ECA)_"^^"
.;fac^dfn^ssn^name^in/out^day^^adm date^disc date^mov #^type^losing ward^treat spec ^los^attending physician^movement type^mov time^gaining ward^adm time
.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,2)=""
.S DA=EC7,DIK="^ECX("_ECFILE_"," D IX^DIK K DIK,DA
.I $D(ZTQUEUED),ECRN>499,'(ECRN#500),$$S^%ZTLOAD S QFLG=1
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
I QFLG S ZTSTOP=1 Q
;
;get treating specialty
S ECFILE=727.822,ECRN=0,QFLG=0
F DFN=0:0 S DFN=$O(^TMP($J,DFN)) Q:'DFN F ECCA=0:0 S ECCA=$O(^TMP($J,DFN,ECCA)) Q:'ECCA S ECM=$O(^DGPM("ATS",DFN,ECCA,ECD0)) I ECM S EC=$O(^(ECM,0)),ECDA=+$O(^(+EC,0)) I $D(^DGPM(ECDA,0)) S EC=^(0) D Q:QFLG
.Q:'$D(^DPT(DFN,0)) S D0=^(0),ECMT=$P(EC,U,18),ECDAT=ECED,ECTM=$E($P(ECDAT,".",2)_"000000",1,6),ECXYM=$$ECXYM^ECXUTL(ECDAT)
.S ECA=^DGPM($P(EC,U,14),0),EC=ECA
.S X1=ECD,(ECA,X2)=$P(EC,U) D ^%DTC S LOS=X
.S ECTRT="" F ECDA=ECCA:1:ECCA+10 S EC=$G(^DGPM(ECDA,0)) I $P(EC,U,14)=ECCA,$P(EC,U,2)=6 S ECTRT=$P($G(^DIC(45.7,+$P(EC,U,9),0)),U,2) Q
.;get treating specialty associated with admission
.S ECODE=U_DFN_U_$P(D0,U,9)_U_$E($P($P(D0,U),",")_" ",1,4)_"^3^"_$$ECXDATE^ECXUTL(ECD,ECXYM)_"^^"_$$ECXDATE^ECXUTL(ECA,ECXYM)_"^^"_ECDA_"^6^^"_ECTRT_U_LOS
.S ECODE=ECODE_U_ECPRO_$P(EC,U,19)_U_ECMT_U_ECTM_U_$$ECXTIME^ECXUTL(+ECA)_"^^^"
.;fac^dfn^ssn^name^i/o^day^product^adm date^dis date^mov#^type^gaining ward^treat spec^duration^attending physician^movement type^trt time^adm time
.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,8)=""
.S DA=EC7,DIK="^ECX("_ECFILE_"," D IX^DIK K DIK,DA
.I $D(ZTQUEUED),ECRN>499,'(ECRN#500),$$S^%ZTLOAD S QFLG=1
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
I QFLG S ZTSTOP=1 Q
;
LOAD ; into files 727.802, 727.808 and 727.818
S ECCNT=0,ECVER=7
I $$S^%ZTLOAD S ZTSTOP=1 K ^TMP($J) Q
S ECFR=727.82,ECFILE=727.802,ECPACK="Admission (setup)",ECHEAD="ADM",ECGRP="ADMS",ECYM="" D MOVE
I $$S^%ZTLOAD S ZTSTOP=1 K ^TMP($J) Q
S ECFR=727.821,ECFILE=727.808,ECPACK="Movement (setup)",ECHEAD="MOV",ECGRP="MOVS",ECYM="" D MOVE
I $$S^%ZTLOAD S ZTSTOP=1 K ^TMP($J) Q
S ECFR=727.822,ECFILE=727.817,ECPACK="Treating specialty change (setup)",ECHEAD="TRT",ECGRP="TREAT",ECYM="" D MOVE
S ^ECX(728,1,"S")=DT ;clear running flag set done date
K XMY S Y=$$HTE^XLFDT($H)
S XMDUZ="DSS SYSTEM",XMSUB="SETUP EXTRACT FOR DSS",XMY("G.DSS-ADMS@"_^XMB("NETNAME"))=""
S ECM(1)="The DSS setup extract completed on "_$P(Y,"@")_" at "_$P(Y,"@",2),ECM(2)="A total of "_ECCNT_" extract file entries were created."
S XMTEXT="ECM(" D ^XMD
S ZTREQ="@" K ^TMP($J)
Q
;
MOVE ;
F S ECYM=$O(^ECX(ECFR,"AM",ECYM)) Q:ECYM="" D UP727 D
.F EC0=0:0 S EC0=$O(^ECX(ECFR,"AM",ECYM,EC0)) Q:'EC0 S ECD=^ECX(ECFR,EC0,0),$P(ECD,U,3)=EC3 D
..S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
..S ^ECX(ECFILE,EC7,0)=EC7_U_$P(ECD,U,2,200),ECRN=ECRN+1 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX^DIK K DIK,DA
..S ^ECX(ECFILE,EC7,1)=^ECX(ECFR,EC0,1)
..S DIK="^ECX("_ECFR_",",DA=EC0 D ^DIK
..S ECCNT=ECCNT+1
.S $P(^ECX(727,EC3,0),U,6)=ECRN
.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
Q
;
UP727 ;update file #727
S EC=$P(^ECX(727,0),U,3)+1,$P(^(0),U,3,4)=EC_U_EC
S ^ECX(727,EC,0)=EC_U_DT_U_ECPACK_U_ECED_U_ECED
S ^ECX(727,EC,"HEAD")=ECHEAD
S ^ECX(727,EC,"FILE")=ECFILE
S ^ECX(727,EC,"GRP")=ECGRP,^ECX(727,EC,"DIV")=ECINST
S DA=EC,DIK="^ECX(727," D IX^DIK K DA,DIK
S ECRN=0,EC3=EC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXSETU1 5095 printed Apr 09, 2024@20:55:46 Page 2
ECXSETU1 ;BIR/DMA,CML,PTD-Get Movements and Treating Speciality for Setup ; [ 01/10/97 4:34 PM ]
+1 ;;3.0;DSS EXTRACTS;**8,24**;Dec 22, 1997
EN ;entry point
+1 ;get movements
+2 SET ECFILE=727.821
SET ECRN=0
SET QFLG=0
+3 FOR DFN=0:0
SET DFN=$ORDER(^TMP($JOB,DFN))
if 'DFN
QUIT
FOR ECCA=0:0
SET ECCA=$ORDER(^TMP($JOB,DFN,ECCA))
if 'ECCA
QUIT
SET ECM=$ORDER(^DGPM("APMV",DFN,ECCA,ECD0))
IF ECM
SET ECDA=$ORDER(^(ECM,0))
IF ECDA
IF ECDA'=ECCA
IF $DATA(^DGPM(+ECDA,0))
SET EC=^(0)
SET DFN=+$PIECE(EC,U,3)
Begin DoDot:1
+4 if '$DATA(^DPT(DFN,0))
QUIT
SET D0=^DPT(DFN,0)
SET ECDAT=ECED
SET ECTM=$EXTRACT($PIECE(ECDAT,".",2)_"000000",1,6)
SET ECXYM=$$ECXYM^ECXUTL(ECDAT)
SET ECMT=$PIECE(EC,U,18)
SET ECMT=$SELECT(ECMT<22:ECMT,ECMT<25:4,ECMT=25:3,ECMT=26:2,1:ECMT)
+5 ;from absence becomes transfer, from auth to unauth becomes to unauth
+6 ;from unauth to auth becomes to auth
+7 SET WTO=$PIECE(EC,U,6)
SET WTO=$PIECE($GET(^DIC(42,+WTO,44)),U)
+8 SET ECCA=$PIECE(EC,U,14)
SET EC=^DGPM(ECCA,0)
SET ECA=$EXTRACT($PIECE(EC,U),".")
+9 ;use admit as previous transfer
+10 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)
+11 SET ECODE=FAC_U_DFN_U_$PIECE(D0,U,9)_U_$EXTRACT($PIECE($PIECE(D0,U),",")_" ",1,4)_"^3^"_$$ECXDATE^ECXUTL(ECD,ECXYM)_U
+12 SET ECA=$PIECE($GET(^DGPM(+$PIECE(EC,U,14),0)),U)
+13 SET X1=ECD
SET X2=$PIECE(EC,U)
DO ^%DTC
SET LOS=X
+14 SET ECODE=ECODE_U_$$ECXDATE^ECXUTL(ECA,ECXYM)_"^^"_ECDA_"^2^"_W_"^^"_LOS_"^^"_ECMT_U_ECTM_U_WTO_U_$$ECXTIME^ECXUTL(ECA)_"^^"
+15 ;fac^dfn^ssn^name^in/out^day^^adm date^disc date^mov #^type^losing ward^treat spec ^los^attending physician^movement type^mov time^gaining ward^adm time
+16 SET EC7=$ORDER(^ECX(ECFILE,999999999),-1)
SET EC7=EC7+1
+17 SET ^ECX(ECFILE,EC7,0)=EC7_U_ECXYM_U_U_ECODE
SET ECRN=ECRN+1
+18 SET $PIECE(^ECX(ECFILE,EC7,1),U,2)=""
+19 SET DA=EC7
SET DIK="^ECX("_ECFILE_","
DO IX^DIK
KILL DIK,DA
+20 IF $DATA(ZTQUEUED)
IF ECRN>499
IF '(ECRN#500)
IF $$S^%ZTLOAD
SET QFLG=1
End DoDot:1
if QFLG
QUIT
+21 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
+22 IF QFLG
SET ZTSTOP=1
QUIT
+23 ;
+24 ;get treating specialty
+25 SET ECFILE=727.822
SET ECRN=0
SET QFLG=0
+26 FOR DFN=0:0
SET DFN=$ORDER(^TMP($JOB,DFN))
if 'DFN
QUIT
FOR ECCA=0:0
SET ECCA=$ORDER(^TMP($JOB,DFN,ECCA))
if 'ECCA
QUIT
SET ECM=$ORDER(^DGPM("ATS",DFN,ECCA,ECD0))
IF ECM
SET EC=$ORDER(^(ECM,0))
SET ECDA=+$ORDER(^(+EC,0))
IF $DATA(^DGPM(ECDA,0))
SET EC=^(0)
Begin DoDot:1
+27 if '$DATA(^DPT(DFN,0))
QUIT
SET D0=^(0)
SET ECMT=$PIECE(EC,U,18)
SET ECDAT=ECED
SET ECTM=$EXTRACT($PIECE(ECDAT,".",2)_"000000",1,6)
SET ECXYM=$$ECXYM^ECXUTL(ECDAT)
+28 SET ECA=^DGPM($PIECE(EC,U,14),0)
SET EC=ECA
+29 SET X1=ECD
SET (ECA,X2)=$PIECE(EC,U)
DO ^%DTC
SET LOS=X
+30 SET ECTRT=""
FOR ECDA=ECCA:1:ECCA+10
SET EC=$GET(^DGPM(ECDA,0))
IF $PIECE(EC,U,14)=ECCA
IF $PIECE(EC,U,2)=6
SET ECTRT=$PIECE($GET(^DIC(45.7,+$PIECE(EC,U,9),0)),U,2)
QUIT
+31 ;get treating specialty associated with admission
+32 SET ECODE=U_DFN_U_$PIECE(D0,U,9)_U_$EXTRACT($PIECE($PIECE(D0,U),",")_" ",1,4)_"^3^"_$$ECXDATE^ECXUTL(ECD,ECXYM)_"^^"_$$ECXDATE^ECXUTL(ECA,ECXYM)_"^^"_ECDA_"^6^^"_ECTRT_U_LOS
+33 SET ECODE=ECODE_U_ECPRO_$PIECE(EC,U,19)_U_ECMT_U_ECTM_U_$$ECXTIME^ECXUTL(+ECA)_"^^^"
+34 ;fac^dfn^ssn^name^i/o^day^product^adm date^dis date^mov#^type^gaining ward^treat spec^duration^attending physician^movement type^trt time^adm time
+35 SET EC7=$ORDER(^ECX(ECFILE,999999999),-1)
SET EC7=EC7+1
+36 SET ^ECX(ECFILE,EC7,0)=EC7_U_ECXYM_U_U_ECODE
SET ECRN=ECRN+1
+37 SET $PIECE(^ECX(ECFILE,EC7,1),U,8)=""
+38 SET DA=EC7
SET DIK="^ECX("_ECFILE_","
DO IX^DIK
KILL DIK,DA
+39 IF $DATA(ZTQUEUED)
IF ECRN>499
IF '(ECRN#500)
IF $$S^%ZTLOAD
SET QFLG=1
End DoDot:1
if QFLG
QUIT
+40 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
+41 IF QFLG
SET ZTSTOP=1
QUIT
+42 ;
LOAD ; into files 727.802, 727.808 and 727.818
+1 SET ECCNT=0
SET ECVER=7
+2 IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ^TMP($JOB)
QUIT
+3 SET ECFR=727.82
SET ECFILE=727.802
SET ECPACK="Admission (setup)"
SET ECHEAD="ADM"
SET ECGRP="ADMS"
SET ECYM=""
DO MOVE
+4 IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ^TMP($JOB)
QUIT
+5 SET ECFR=727.821
SET ECFILE=727.808
SET ECPACK="Movement (setup)"
SET ECHEAD="MOV"
SET ECGRP="MOVS"
SET ECYM=""
DO MOVE
+6 IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ^TMP($JOB)
QUIT
+7 SET ECFR=727.822
SET ECFILE=727.817
SET ECPACK="Treating specialty change (setup)"
SET ECHEAD="TRT"
SET ECGRP="TREAT"
SET ECYM=""
DO MOVE
+8 ;clear running flag set done date
SET ^ECX(728,1,"S")=DT
+9 KILL XMY
SET Y=$$HTE^XLFDT($HOROLOG)
+10 SET XMDUZ="DSS SYSTEM"
SET XMSUB="SETUP EXTRACT FOR DSS"
SET XMY("G.DSS-ADMS@"_^XMB("NETNAME"))=""
+11 SET ECM(1)="The DSS setup extract completed on "_$PIECE(Y,"@")_" at "_$PIECE(Y,"@",2)
SET ECM(2)="A total of "_ECCNT_" extract file entries were created."
+12 SET XMTEXT="ECM("
DO ^XMD
+13 SET ZTREQ="@"
KILL ^TMP($JOB)
+14 QUIT
+15 ;
MOVE ;
+1 FOR
SET ECYM=$ORDER(^ECX(ECFR,"AM",ECYM))
if ECYM=""
QUIT
DO UP727
Begin DoDot:1
+2 FOR EC0=0:0
SET EC0=$ORDER(^ECX(ECFR,"AM",ECYM,EC0))
if 'EC0
QUIT
SET ECD=^ECX(ECFR,EC0,0)
SET $PIECE(ECD,U,3)=EC3
Begin DoDot:2
+3 SET EC7=$ORDER(^ECX(ECFILE,999999999),-1)
SET EC7=EC7+1
+4 SET ^ECX(ECFILE,EC7,0)=EC7_U_$PIECE(ECD,U,2,200)
SET ECRN=ECRN+1
SET DA=EC7
SET DIK="^ECX("_ECFILE_","
DO IX^DIK
KILL DIK,DA
+5 SET ^ECX(ECFILE,EC7,1)=^ECX(ECFR,EC0,1)
+6 SET DIK="^ECX("_ECFR_","
SET DA=EC0
DO ^DIK
+7 SET ECCNT=ECCNT+1
End DoDot:2
+8 SET $PIECE(^ECX(727,EC3,0),U,6)=ECRN
+9 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
End DoDot:1
+10 QUIT
+11 ;
UP727 ;update file #727
+1 SET EC=$PIECE(^ECX(727,0),U,3)+1
SET $PIECE(^(0),U,3,4)=EC_U_EC
+2 SET ^ECX(727,EC,0)=EC_U_DT_U_ECPACK_U_ECED_U_ECED
+3 SET ^ECX(727,EC,"HEAD")=ECHEAD
+4 SET ^ECX(727,EC,"FILE")=ECFILE
+5 SET ^ECX(727,EC,"GRP")=ECGRP
SET ^ECX(727,EC,"DIV")=ECINST
+6 SET DA=EC
SET DIK="^ECX(727,"
DO IX^DIK
KILL DA,DIK
+7 SET ECRN=0
SET EC3=EC
+8 QUIT
