source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXTRYIT.m@ 1739

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

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1ECXTRYIT ;BIR/DMA-Test Run for Setup Extract Print Population ; [ 07/24/96 1:30 PM ]
2 ;;3.0;DSS EXTRACTS;;Dec 22, 1997
3EN ;entry point from ooption
4 I '$D(DT) S DT=$$HTFM^XLFDT(+$H)
5 W !!,"This option will print 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.",!!
6 W !!,"NOTE - This will generate a report of your inpatient population on the",!,"BEGINNING of the day you select, not the end of the day as MAS reports do.",!
7 W "For example, for this report, if you choose October 1, 1994, the report will",!,"start at midnight at the beginning of the day."
8 W " For the MAS report, you would",!,"choose September 30, 1994. The MAS report begins at midnight at the end",!,"of the day.",!!!
9DATE S DIR(0)="D",DIR("A")="Select the date ",DIR("B")=$$HTE^XLFDT($H-1) D ^DIR K DIR G END:$D(DIRUT) S ECD=Y I Y>DT W !!,"Must be a date in the past",!! G DATE
10 W !!,"This report must be queued to a 132 column printer.",!
11 S %ZIS="NQ" D ^%ZIS K %ZIS G END:POP S ZTSAVE("ECD")="",ZTDESC="Print inpatient list (DSS)",ZTRTN="START^ECXTRYIT" D ^%ZTLOAD
12END K POP,X,Y,ECD D ^%ZISC Q
13 ;
14START ;queued entry point
15 K ^TMP($J) S DFN="",ECD0=9999999.9999999-ECD
16 F 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)) S EC=^(0),ECX=+$P(EC,"^",17),ECAS=$P(EC,"^",18)=40 S:$S('ECX:1,$G(^DGPM(ECX,0))>ECD:1,1:0) ^TMP($J,DFN,ECDA)=$P(EC,"^",6) I ECAS D
17 .F EC1=EC1:0 S EC1=$O(^DGPM("ATID1",DFN,EC1)) Q:'EC1 S ECDA=$O(^(EC1,0)) I ECDA S EC=^DGPM(ECDA,0) I $P(EC,"^",18)'=40 S ECX=$P(EC,"^",17) Q
18 .I EC1,ECDA,$S('ECX:1,'$D(^DGPM(ECX,0)):1,^DGPM(ECX,0)>ECD:1,1:0) S ^TMP($J,DFN,ECDA)=$P(EC,"^",6)
19 ;
20 S DFN=0 F S DFN=$O(^TMP($J,DFN)) Q:'DFN S X=$O(^(DFN,0)) I $O(^(X)) K ^(X)
21 ;if he has an NHCU and an ASIH open, get rid of the NHCU one since
22 ;he may have been transferred in the hospital and we don't want to
23 ;find him twice
24 ;
25 ;now hunt transfers
26 ;
27 S DFN=0 F S DFN=$O(^TMP($J,DFN)),ECCA=0 Q:'DFN F 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),^TMP($J,DFN,ECCA)=$P(EC,"^",6)
28 ;
29 ;now put in name order
30 S DFN=0 F S DFN=$O(^TMP($J,DFN)),ECCA=0 Q:'DFN F S ECCA=$O(^TMP($J,DFN,ECCA)) Q:'ECCA D
31 .S W=+^(ECCA),W=$P($G(^DIC(42,W,0)),"^") S:W="" W="unknown" S ^TMP($J,"L",W,$P(^DPT(DFN,0),"^")_"^"_DFN)=$P(^DPT(DFN,0),"^",9)_"^"_$P($P(^DGPM(ECCA,0),"^"),".")
32 ;
33 S W="" F S W=$O(^TMP($J,"L",W)),NAM="" Q:W="" D HEAD F S NAM=$O(^TMP($J,"L",W,NAM)) Q:NAM="" S EC=^(NAM) W !,?5,$P(NAM,"^"),?45,$P(EC,"^"),?66,$$FMTE^XLFDT($P(EC,"^",2)) I $Y+4>IOSL,$O(^TMP($J,"L",W,NAM))]"" D HEAD
34 K ^TMP($J) S ZTREQ="@" D ^%ZISC Q
35 ;
36HEAD W:$Y @IOF W !!,?30,"INPATIENT WARD LIST (DSS) FOR ",$$FMTE^XLFDT(ECD)," FOR WARD ",W,!!,?12,"PATIENT",?50,"SSN",?66,"ADMIT DATE",!
37 Q
Note: See TracBrowser for help on using the repository browser.