ECXTRYIT ;BIR/DMA-Test Run for Setup Extract Print Population ;6/15/17 15:30
;;3.0;DSS EXTRACTS;**166**;Dec 22, 1997;Build 24
EN ;entry point from ooption
I '$D(DT) S DT=$$HTFM^XLFDT(+$H)
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.",!!
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/HAS reports",!
W "do. For example, for this report, 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.",!!!
DATE 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
W !!,"This report must be queued to a 132 column printer.",!
S %ZIS="NQ" D ^%ZIS K %ZIS G END:POP S ZTSAVE("ECD")="",ZTDESC="Print inpatient list (DSS)",ZTRTN="START^ECXTRYIT" D ^%ZTLOAD
END K POP,X,Y,ECD,DIRUT,DUOUT,DTOUT D ^%ZISC Q ;166
;
START ;queued entry point
N NAM,DFN,ECD0,EC1,ECDA,EC,ECX,ECAS,ECCA,ECM,W ;166
K ^TMP($J) S DFN="",ECD0=9999999.9999999-ECD
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
.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
.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)
;
S DFN=0 F S DFN=$O(^TMP($J,DFN)) Q:'DFN S X=$O(^(DFN,0)) I $O(^(X)) K ^(X)
;if he has an NHCU and an ASIH open, get rid of the NHCU one since
;he may have been transferred in the hospital and we don't want to
;find him twice
;
;now hunt transfers
;
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)
;
;now put in name order
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
.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),"^"),".")
;
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
K ^TMP($J) S ZTREQ="@" D ^%ZISC Q
;
HEAD W:$Y @IOF W !!,?30,"INPATIENT WARD LIST (DSS) FOR ",$$FMTE^XLFDT(ECD)," FOR WARD ",W,!!,?12,"PATIENT",?50,"SSN",?66,"ADMIT DATE",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXTRYIT 3048 printed Apr 09, 2024@20:59:34 Page 2
ECXTRYIT ;BIR/DMA-Test Run for Setup Extract Print Population ;6/15/17 15:30
+1 ;;3.0;DSS EXTRACTS;**166**;Dec 22, 1997;Build 24
EN ;entry point from ooption
+1 IF '$DATA(DT)
SET DT=$$HTFM^XLFDT(+$HOROLOG)
+2 WRITE !!,"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.",!!
+3 WRITE !!,"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/HAS reports",!
+4 WRITE "do. For example, for this report, if you choose October 1, 1994, the report",!,"will start at midnight at the beginning of the day."
+5 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.",!!!
DATE SET DIR(0)="D"
SET DIR("A")="Select the date "
SET DIR("B")=$$HTE^XLFDT($HOROLOG-1)
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET ECD=Y
IF Y>DT
WRITE !!,"Must be a date in the past",!!
GOTO DATE
+1 WRITE !!,"This report must be queued to a 132 column printer.",!
+2 SET %ZIS="NQ"
DO ^%ZIS
KILL %ZIS
if POP
GOTO END
SET ZTSAVE("ECD")=""
SET ZTDESC="Print inpatient list (DSS)"
SET ZTRTN="START^ECXTRYIT"
DO ^%ZTLOAD
END ;166
KILL POP,X,Y,ECD,DIRUT,DUOUT,DTOUT
DO ^%ZISC
QUIT
+1 ;
START ;queued entry point
+1 ;166
NEW NAM,DFN,ECD0,EC1,ECDA,EC,ECX,ECAS,ECCA,ECM,W
+2 KILL ^TMP($JOB)
SET DFN=""
SET ECD0=9999999.9999999-ECD
+3 FOR
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))
SET EC=^(0)
SET ECX=+$PIECE(EC,"^",17)
SET ECAS=$PIECE(EC,"^",18)=40
if $SELECT('ECX
SET ^TMP($JOB,DFN,ECDA)=$PIECE(EC,"^",6)
IF ECAS
Begin DoDot:1
+4 FOR EC1=EC1:0
SET EC1=$ORDER(^DGPM("ATID1",DFN,EC1))
if 'EC1
QUIT
SET ECDA=$ORDER(^(EC1,0))
IF ECDA
SET EC=^DGPM(ECDA,0)
IF $PIECE(EC,"^",18)'=40
SET ECX=$PIECE(EC,"^",17)
QUIT
+5 IF EC1
IF ECDA
IF $SELECT('ECX:1,'$DATA(^DGPM(ECX,0)):1,^DGPM(ECX,0)>ECD:1,1:0)
SET ^TMP($JOB,DFN,ECDA)=$PIECE(EC,"^",6)
End DoDot:1
+6 ;
+7 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,DFN))
if 'DFN
QUIT
SET X=$ORDER(^(DFN,0))
IF $ORDER(^(X))
KILL ^(X)
+8 ;if he has an NHCU and an ASIH open, get rid of the NHCU one since
+9 ;he may have been transferred in the hospital and we don't want to
+10 ;find him twice
+11 ;
+12 ;now hunt transfers
+13 ;
+14 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,DFN))
SET ECCA=0
if 'DFN
QUIT
FOR
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 ^TMP($JOB,DFN,ECCA)=$PIECE(EC,"^",6)
+15 ;
+16 ;now put in name order
+17 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,DFN))
SET ECCA=0
if 'DFN
QUIT
FOR
SET ECCA=$ORDER(^TMP($JOB,DFN,ECCA))
if 'ECCA
QUIT
Begin DoDot:1
+18 SET W=+^(ECCA)
SET W=$PIECE($GET(^DIC(42,W,0)),"^")
if W=""
SET W="unknown"
SET ^TMP($JOB,"L",W,$PIECE(^DPT(DFN,0),"^")_"^"_DFN)=$PIECE(^DPT(DFN,0),"^",9)_"^"_$PIECE($PIECE(^DGPM(ECCA,0),"^"),".")
End DoDot:1
+19 ;
+20 SET W=""
FOR
SET W=$ORDER(^TMP($JOB,"L",W))
SET NAM=""
if W=""
QUIT
DO HEAD
FOR
SET NAM=$ORDER(^TMP($JOB,"L",W,NAM))
if NAM=""
QUIT
SET EC=^(NAM)
WRITE !,?5,$PIECE(NAM,"^"),?45,$PIECE(EC,"^"),?66,$$FMTE^XLFDT($PIECE(EC,"^",2))
IF $Y+4>IOSL
IF $ORDER(^TMP($JOB,"L",W,NAM))]""
DO HEAD
+21 KILL ^TMP($JOB)
SET ZTREQ="@"
DO ^%ZISC
QUIT
+22 ;
HEAD if $Y
WRITE @IOF
WRITE !!,?30,"INPATIENT WARD LIST (DSS) FOR ",$$FMTE^XLFDT(ECD)," FOR WARD ",W,!!,?12,"PATIENT",?50,"SSN",?66,"ADMIT DATE",!
+1 QUIT
