source: FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXSETU1.m@ 1123

Last change on this file since 1123 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.9 KB
Line 
1ECXSETU1 ;BIR/DMA,CML,PTD-Get Movements and Treating Speciality for Setup ; [ 01/10/97 4:34 PM ]
2 ;;3.0;DSS EXTRACTS;**8,24**;Dec 22, 1997
3EN ;entry point
4 ;get movements
5 S ECFILE=727.821,ECRN=0,QFLG=0
6 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
7 .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)
8 .;from absence becomes transfer, from auth to unauth becomes to unauth
9 .;from unauth to auth becomes to auth
10 .S WTO=$P(EC,U,6),WTO=$P($G(^DIC(42,+WTO,44)),U)
11 .S ECCA=$P(EC,U,14),EC=^DGPM(ECCA,0),ECA=$E($P(EC,U),".")
12 .;use admit as previous transfer
13 .S W=$P(EC,U,6),FAC=$P($G(^DIC(42,+W,0)),U,11),W=$P($G(^DIC(42,+W,44)),U)
14 .S ECODE=FAC_U_DFN_U_$P(D0,U,9)_U_$E($P($P(D0,U),",")_" ",1,4)_"^3^"_$$ECXDATE^ECXUTL(ECD,ECXYM)_U
15 .S ECA=$P($G(^DGPM(+$P(EC,U,14),0)),U)
16 .S X1=ECD,X2=$P(EC,U) D ^%DTC S LOS=X
17 .S ECODE=ECODE_U_$$ECXDATE^ECXUTL(ECA,ECXYM)_"^^"_ECDA_"^2^"_W_"^^"_LOS_"^^"_ECMT_U_ECTM_U_WTO_U_$$ECXTIME^ECXUTL(ECA)_"^^"
18 .;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
19 .S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
20 .S ^ECX(ECFILE,EC7,0)=EC7_U_ECXYM_U_U_ECODE,ECRN=ECRN+1
21 .S $P(^ECX(ECFILE,EC7,1),U,2)=""
22 .S DA=EC7,DIK="^ECX("_ECFILE_"," D IX^DIK K DIK,DA
23 .I $D(ZTQUEUED),ECRN>499,'(ECRN#500),$$S^%ZTLOAD S QFLG=1
24 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
25 I QFLG S ZTSTOP=1 Q
26 ;
27 ;get treating specialty
28 S ECFILE=727.822,ECRN=0,QFLG=0
29 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
30 .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)
31 .S ECA=^DGPM($P(EC,U,14),0),EC=ECA
32 .S X1=ECD,(ECA,X2)=$P(EC,U) D ^%DTC S LOS=X
33 .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
34 .;get treating specialty associated with admission
35 .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
36 .S ECODE=ECODE_U_ECPRO_$P(EC,U,19)_U_ECMT_U_ECTM_U_$$ECXTIME^ECXUTL(+ECA)_"^^^"
37 .;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
38 .S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
39 .S ^ECX(ECFILE,EC7,0)=EC7_U_ECXYM_U_U_ECODE,ECRN=ECRN+1
40 .S $P(^ECX(ECFILE,EC7,1),U,8)=""
41 .S DA=EC7,DIK="^ECX("_ECFILE_"," D IX^DIK K DIK,DA
42 .I $D(ZTQUEUED),ECRN>499,'(ECRN#500),$$S^%ZTLOAD S QFLG=1
43 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
44 I QFLG S ZTSTOP=1 Q
45 ;
46LOAD ; into files 727.802, 727.808 and 727.818
47 S ECCNT=0,ECVER=7
48 I $$S^%ZTLOAD S ZTSTOP=1 K ^TMP($J) Q
49 S ECFR=727.82,ECFILE=727.802,ECPACK="Admission (setup)",ECHEAD="ADM",ECGRP="ADMS",ECYM="" D MOVE
50 I $$S^%ZTLOAD S ZTSTOP=1 K ^TMP($J) Q
51 S ECFR=727.821,ECFILE=727.808,ECPACK="Movement (setup)",ECHEAD="MOV",ECGRP="MOVS",ECYM="" D MOVE
52 I $$S^%ZTLOAD S ZTSTOP=1 K ^TMP($J) Q
53 S ECFR=727.822,ECFILE=727.817,ECPACK="Treating specialty change (setup)",ECHEAD="TRT",ECGRP="TREAT",ECYM="" D MOVE
54 S ^ECX(728,1,"S")=DT ;clear running flag set done date
55 K XMY S Y=$$HTE^XLFDT($H)
56 S XMDUZ="DSS SYSTEM",XMSUB="SETUP EXTRACT FOR DSS",XMY("G.DSS-ADMS@"_^XMB("NETNAME"))=""
57 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."
58 S XMTEXT="ECM(" D ^XMD
59 S ZTREQ="@" K ^TMP($J)
60 Q
61 ;
62MOVE ;
63 F S ECYM=$O(^ECX(ECFR,"AM",ECYM)) Q:ECYM="" D UP727 D
64 .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
65 ..S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
66 ..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
67 ..S ^ECX(ECFILE,EC7,1)=^ECX(ECFR,EC0,1)
68 ..S DIK="^ECX("_ECFR_",",DA=EC0 D ^DIK
69 ..S ECCNT=ECCNT+1
70 .S $P(^ECX(727,EC3,0),U,6)=ECRN
71 .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
72 Q
73 ;
74UP727 ;update file #727
75 S EC=$P(^ECX(727,0),U,3)+1,$P(^(0),U,3,4)=EC_U_EC
76 S ^ECX(727,EC,0)=EC_U_DT_U_ECPACK_U_ECED_U_ECED
77 S ^ECX(727,EC,"HEAD")=ECHEAD
78 S ^ECX(727,EC,"FILE")=ECFILE
79 S ^ECX(727,EC,"GRP")=ECGRP,^ECX(727,EC,"DIV")=ECINST
80 S DA=EC,DIK="^ECX(727," D IX^DIK K DA,DIK
81 S ECRN=0,EC3=EC
82 Q
Note: See TracBrowser for help on using the repository browser.