source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGSCHAD3.m@ 1800

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

initial load of WorldVistAEHR

File size: 2.9 KB
RevLine 
[613]1DGSCHAD3 ;ALB/MTC - OUTPUT FUTURE SCHEDULED ADMISSION DATA ; 11 MAY 87
2 ;;5.3;Registration;**60,71**;Aug 13, 1993
3 ;
4 D OLD^DGSCHAD2 G Q:DGERR!(DGOLD=0) S Y=$S(DT<DGOLD1:DGOLD1,1:DT) X ^DD("DD") S DGTD=Y
5F W ! S %DT("A")="Start with DATE OF RESERVATION: ",%DT("B")=DGTD,%DT="EAX",%DT(0)=DGOLD1 D ^%DT K %DT G Q:Y'>0 S (DGFR,DGHFR)=Y,X1=DGFR,X2=-1 D C^%DTC S DGFR1=X_".9999"
6 W ! S Y=DGFR X ^DD("DD") S DGFR=Y,%DT("A")=" Go to DATE OF RESERVATION: ",%DT("B")=Y,%DT="EAX",%DT(0)=DGHFR K DGHFR D ^%DT K %DT G Q:Y'>0 S DGTO1=Y X ^DD("DD") S DGTO=Y,DGTO1=DGTO1_".9999"
7 S DHD="Scheduled Admission List for "_$S(DGTO'=DGFR:"period covering ",1:"")_DGFR_$S(DGTO'=DGFR:" through "_DGTO,1:"")_"."
81 D H^DGUTL S Z="^SCHEDULED^CANCELLED^BOTH^" R !!,"List (S)cheduled, (C)ancelled or (B)oth scheduled admissions: BOTH// ",X:DTIME S:'$T X="^" W:X="" "B" S:X="" X="B" D IN^DGHELP I X["^" G Q
9 I %=-1 W !!?4,"C - To list only future scheduled admissions which have been cancelled.",!?4,"S - To list only active future scheduled admissions.",!?4,"B - To list all future scheduled admissions regardless of status." G 1
10 S DGSCH=X,(BY,FR,TO)="" D DIV^DGUTL I DGDIV G 2
11 D DIVISION^VAUTOMA G:VAUTD']""&('$O(VAUTD(0)))!(Y=-1) Q
12 I VAUTD=1 S BY="12,",FR=FR_"@,",TO=TO_"," G 2
13 S DGDIV=0,BY="12," K TO,FR S TO(1)="",FR(1)=""
14 N DIS S DIS(0)="I VAUTD!$D(VAUTD(+$P(^DGS(41.1,D0,0),""^"",12)))"
15 D H^DGUTL S BY=BY_"@2,.01,",FR(2)=DGFR1,FR(3)="",TO(2)=DGTO1,TO(3)="" I "SC"[DGSCH S BY=BY_"'13" S:DGSCH="S" TO(4)="@",FR(4)="@" I DGSCH="C" S TO(4)="",FR(4)=""
16 G 3
172 D H^DGUTL S BY=BY_"@2,.01,",FR=FR_DGFR1_",,",TO=TO_DGTO1_",," I "SC"[DGSCH S BY=BY_"'13" S:DGSCH="S" TO=TO_"@,",FR=FR_"@," I DGSCH="C" S TO=TO_",",FR=FR_","
183 S DGNO=0 S X=1 D ^DGTEMP G Q:DGNO S FLDS=X,L=0,DIC="^DGS(41.1," W !!?15,*7,"This output requires 132 columns",!! D EN1^DIP
19Q K X,DGERR,DGOLD,DGOLD1,DGNO,DGTEMP,DGDIV,DGSCH,DGDATE,DGTIME Q
20TEMP S DGSA=^DGS(41.1,D0,0),DFN=+DGSA,DGPT=$S($D(^DPT(DFN,0)):^(0),1:""),Y=$P(DGSA,U,2) X ^DD("DD") W ?28,$E($P(DGPT,U,9),6,9),?35,"Phone: ",$S($D(^DPT(DFN,.13)):$P(^(.13),U),1:"UNKNOWN"),?60,"Reservation: ",Y
21 W ?95,$S($P(DGSA,U,10)="W":"Ward Loc: "_$S($D(^DIC(42,+$P(DGSA,U,8),0)):$P(^(0),U),1:"UNKNOWN"),$P(DGSA,U,10)="T":"Treat Sp: "_$S($D(^DIC(45.7,+$P(DGSA,U,9),0)):$P(^(0),U),1:"UNKNOWN"),1:"")
22 W !?32,"Provider: "_$S($P(DGSA,U,5)]""&($D(^VA(200,+$P(DGSA,U,5),0))):$P(^(0),U),1:"UNKNOWN"),?96,"Surgery: "_$S($P(DGSA,U,6)="Y":"YES",$P(DGSA,U,6)="N":"NO",1:"UNKNOWN")
23 W !?34,"Status: " I $P(DGSA,U,13)']""&($P(DGSA,U,17)']"") W "SCHEDULED - Admitting Diagnosis '"_$S($P(DGSA,U,4)]"":$P(DGSA,U,4),1:"UNKNOWN")_"',"
24 I ($P(DGSA,U,13)']"")&($P(DGSA,U,17)]"") W "ADMITTED - " I $D(^DGPM($P(DGSA,U,17),0)) S Y=$P(^DGPM($P(DGSA,U,17),0),U) D DD^%DT W Y
25 I $P(DGSA,U,13)]"" W "CANCELLED by: "_$S($P(DGSA,U,14)]"":$P(^VA(200,$P(DGSA,U,14),0),U),1:"UNKNOWN")
26 I DGPT']"" W !,"**PATIENT DELETED FROM PATIENT FILE - CONTACT IRM SERVICE",!!
27 K DGSA,DFN,DGPT,Y
Note: See TracBrowser for help on using the repository browser.