source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGOINPT1.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: 4.7 KB
RevLine 
[613]1DGOINPT1 ;ALB/REW - BUILDS,PRINTS INPATIENT ROSTER ; 8/8/03 11:45am
2 ;;5.3;Registration;**162,498,544,732**;Aug 13, 1993;Build 2
3 ;
4 ;
5 ; DGS1 IS USED FOR SORTING PRINT
6 ; DGS2 IS USED FOR X-REF LOOKUP
7ROSTER ;
8 S X=132 X ^%ZOSF("RM")
9 D NOW^%DTC S Y=$E(%,1,12),DGADMT=$$FMTE^XLFDT(Y,1)
10 S TOT=0,DGS="",DGS1=""
11 I DGHOW="W" S DGXREF="CN" D ROST
12 I DGHOW="P","EP"[DGPVAR S DGXREF="APR" D ROST
13 I DGHOW="P","EA"[DGPVAR S DGXREF="AAP" D ROST
14 I DGHOW="P",DGPVAR="E" D FIXTOT
15 D DOLIST
16QUIT W !
17 K ^TMP($J),DGLIST,DGS,ROOMB,CPS,DFN,DGADMT,DGADM,DGCPYS,DGDAYS,DGDS,DGDV,DGI,DGJ,DGPGM,DGPMDD("DA"),DGVAR,DGWD,DGX,I,J,K,NM,TOT,VAUTD,VAUTW,WD,X,Y
18 K DGHOW,DGPVAR,DGS1,DGSUBS,DGTM,DGUTV,DIC,X1,XMDT,XMM,DGXREF,ZZ,DGPMIFN,DGS2,VADAT,VADATE,VADM,VAEL,VAIN,Z,DGTMPV,DGFL,DIR,DGBID
19 D KVAR^VADPT,KVAR^VADATE,CLOSE^DGUTQ,ENDREP^DGUTL
20 Q
21FIXTOT ;
22 S DGS=""
23 F DGI=0:0 S DGS=$O(^TMP($J,"DGLIST",DGS)) Q:DGS="" D
24 .S DGUTV="^TMP("_$J_","""_DGS_""")"
25 .F ZZ=0:1 S DGUTV=$Q(@DGUTV) Q:DGUTV=""!($TR(DGUTV,"""")'[($J_","_DGS_","))
26 .S ^TMP($J,"DGLIST",DGS)=ZZ
27 Q
28ROST ;
29 F DGI=0:0 S:DGS]""&TOT ^TMP($J,"DGLIST",DGS1)=TOT S TOT=0,DGS=$S((VAUTW):$O(^DPT(DGXREF,DGS)),1:$O(VAUTW(DGS))) Q:DGS="" D CHECK I DGFL S DFN="" F DGJ=0:0 S DFN=$O(^DPT(DGXREF,DGS2,DFN)) Q:DFN="" D ADMDT
30 Q
31ADMDT ;
32 N DGVAIN7,VAL
33 D QKVADPT Q:'VAIN(7) S DGBID=VA("BID") S TOT=TOT+1,X=+VAIN(7),DGVAIN7="" I X S X=$$FMTE^XLFDT(X,"5DF"),X=$TR(X," ","0"),X=$TR(X,"/","-"),DGVAIN7=X
34 S DGPMIFN=VAIN(1) D ^DGPMLOS S DGDAYS=$P(X,"^",5)
35 S VAL=VADM(1)_U_DGBID_U_VADM(4)_U_DGVAIN7_U_DGDAYS_U_VAIN(4)_U_VAIN(5)_U_$P(VAIN(2),U,2)
36 S VAL=VAL_U_$P(VAIN(11),U,2)_U_$P(VAIN(3),U,2)_U_$P(VAEL(9),U,1)_U_$P(VAIP(19,1),U,1)
37 S ^TMP($J,DGS1,$S(DGSUBS="R":+$$RM(VAIN(5)),1:VADM(1)),+DGBID)=VAL
38 Q
39CHECK ;
40 S DGFL=1
41 I DGHOW="P",VAUTW S DGS1=$S($D(^VA(200,DGS,0)):$P($G(^VA(200,DGS,0)),U,1),1:DGS),DGS2=DGS Q
42 I DGHOW="P",'VAUTW S DGS1=DGS,DGS2=VAUTW(DGS) Q
43 S DGWD=$O(^DIC(42,"B",DGS,0)) I DGWD S DGDV=$S('$D(^DIC(42,DGWD,0)):0,+$P(^(0),"^",11):$P(^(0),"^",11),1:$O(^DG(40.8,0)))
44 I 'VAUTD,'$D(VAUTD(DGDV)) S DGFL=0
45 S (DGS1,DGS2)=DGS
46 Q
47WAIT I $E(IOST)="C" S DIR(0)="E" D ^DIR S:'Y DGX=1
48 Q
49DOLIST ;
50 S DGX=0
51 F CPS=1:1:DGCPYS S DGS="" F I=0:0 S DGS=$O(^TMP($J,"DGLIST",DGS)) Q:DGS="" D HEAD,OUT G QTDOL:DGX D WAIT G QTDOL:DGX
52QTDOL Q
53HEAD S X=$S(DGHOW="W":"WARD",DGPVAR="E":"PROVIDER",DGPVAR="P":"PRIMARY PHYSICIAN",1:"ATTENDING PHYSICIAN")_": "_DGS_" "_^TMP($J,"DGLIST",DGS)_" PATIENTS"
54 W:IOF]"" @IOF W !!?4,"INPATIENT ROSTER",?(61-($L(X)/2)),X,?99 W DGADMT
55 W !!?33,"ADMISSION",?78,"PRIMARY",?95,"ATTENDING",?112,"TREATING",?126,"MEANS"
56 W !,"PATIENT NAME",?21,"ID",?28,"AGE",?33,"DATE",?46,"DAYS",?52,"WARD",?67,"ROOM-BED",?78,"PHYSICIAN",?95,"PHYSICIAN",?112,"SPECIALTY",?126,"TEST" K X S $P(X,"-",133)="" W !,X,! Q
57OUT ;
58 S DGUTV="^TMP("_$J_","""_DGS_""")"
59 F ZZ=0:1 S DGUTV=$Q(@DGUTV) Q:DGUTV=""!($TR(DGUTV,"""")'[($J_","_DGS_",")) S DGADM=@DGUTV D PRINT I $Y>(IOSL-6),($TR($Q(@DGUTV),"""")[($J_","_DGS_",")) D LEGEND,WAIT G QTOUT:DGX D HEAD
60 I $Y<(IOSL-5) D LEGEND
61QTOUT Q
62PRINT ;
63 W !,$S($P(DGADM,U,12):"!",1:""),$E($P(DGADM,U,1),1,19),?21,$P(DGADM,U,2),?28,$J($P(DGADM,U,3),3)
64 W ?33,$P(DGADM,U,4),?46,$J($P(DGADM,U,5),4),?52,$E($P(DGADM,U,6),1,14),?67,$E($P(DGADM,U,7),1,9),?78,$E($P(DGADM,U,8),1,15)
65 W ?95,$E($P(DGADM,U,9),1,15),?112,$E($P(DGADM,U,10),1,13),?128,$P(DGADM,U,11) W:DGDS !
66 Q
67RM(ROOMB) ;
68 ;IGNORES CHARACTERS BEFORE THE FIRST NON-ZERO NUMBER
69 ;RETURNS NUMBERS IN ROOM-BED BEFORE THE FIRST '-' OR '/' THE REMAINING
70 ;NUMBERS ARE DIVIDED BY 100,000 AND ADDED TO THE FIRST PART
71 ; E.G. 'A-12E-A103C'
72 ;WILL RETURN: 12.000103
73 ;
74 NEW ROOM1,BEG
75 S ROOM1=$TR(ROOMB,"123456789","111111111")
76 S BEG=$F(ROOM1,1)-1
77 S ROOMB=$TR($E(ROOMB,BEG,99),"-/ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz ~!@#$%^&*()_+=`|\{}[]:"";'<>?,.","..")
78 S:$L(ROOMB,".")>1 ROOMB=$P(ROOMB,".",1)+(($TR(($P(ROOMB,".",2,99)),"."))/1000000)
79 Q +ROOMB
80QKVADPT ;QUICK SUBSTITUTE FOR VADPT:REQUIRES DFN
81 NEW K,I,DGX
82 S K=0
83 F I=.105,.104,.103,.1,.101 S K=K+1,VAIN(K)=$G(^DPT(DFN,I))
84 S VAIN(11)=$G(^DPT(DFN,.1041))
85 S VAIN(7)=+$G(^DGPM(+VAIN(1),0))
86 F I=2,11 S:$D(^VA(200,+VAIN(I),0)) VAIN(I)=VAIN(I)_U_$P(^(0),U,1)
87 S:$D(^DIC(45.7,+VAIN(3),0)) VAIN(3)=VAIN(3)_U_$P(^(0),U,1)
88 ;code added to differentiate ambiguous treating speialty names.
89 S:($E($P(VAIN(3),U,2),1,7)="NH LONG")!($E($P(VAIN(3),U,2),1,8)="NH SHORT") VAIN(3)=$P(^(0),U,2)_U_$P($G(^DIC(42.4,+$P(^(0),U,2),0)),U,2)
90DEM S VADM(1)=$P($G(^DPT(DFN,0)),U,1)
91 S VAIP(19,1)=$P($G(^DGPM(+VAIN(1),"DIR")),"^",1)
92 S:VAIP(19,1)="" VAIP(19,1)=1
93 S DGX=$P($G(^DPT(DFN,0)),U,3)
94 S VADM(4)=$E(DT,1,3)-$E(DGX,1,3)-($E(DT,4,7)<$E(DGX,4,7))
95 D PID^VADPT6
96MT S VAEL(9)=$P($$MTS^DGMTU(DFN),U,2)
97 Q
98LEGEND F Q:($Y>(IOSL-5)) W !
99 W !,"'!' Before the Patient name indicates the patient chose not to be listed in the Facility Directory"
100 Q
Note: See TracBrowser for help on using the repository browser.