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

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

initial load of WorldVistAEHR

File size: 2.7 KB
RevLine 
[613]1DGPTDD ;ALB/LD - DD calls for Suffix fields of PTF file; 27 May 1995
2 ;;5.3;Registration;**58**;Aug 13, 1993
3 ;
4 ; DD calls for the Suffix and Transferring Suffix fields of PTF
5 ; file (#45).
6 ;
7ACTIVE(X,Y,DGADM) ; Suffix active during patient's admission date?
8 ;
9 ; DGEFDT -- Suffix Effective Date
10 ; DGEFIEN -- Suffix Effective Date IEN
11 ; DGSUFPTR -- Suffix pointer from Station Type file
12 ;
13 ; INPUT: X -- Suffix
14 ; Y -- Station Type Number
15 ; DGADM -- PTF IEN (use to get 2nd piece which is
16 ; admission date or use DT if null)
17 ; OUTPUT: DGACT -- Active during admission date? (1=YES,0=NO)
18 ;
19 N DGACT,DGEFDT,DGEFIEN,DGFL,DGSUFPTR,DGI
20 S (DGACT,DGEFIEN,DGEFDT,DGFL,DGSUFPTR)=0
21 F DGI=0:0 S DGI=$O(^DIC(45.81,+$G(Y),"S","B",DGI)) Q:'DGI!$G(DGFL) D
22 .I $P($G(^DIC(45.68,DGI,0)),U)=$G(X) S DGSUFPTR=DGI,DGFL=1
23 I $D(^DGPT(+$G(DGADM),0)) S DGADM=+$P(^(0),U,2)
24 S DGADM=$S(+$G(DGADM)>0:-DGADM,1:-DT) S:$P(DGADM,".",2) DGADM=$P(DGADM,".") S DGADM=DGADM_.2359
25 S DGEFDT=+$O(^DIC(45.68,DGSUFPTR,"E","AEFF",DGADM))
26 I -(DGEFDT)'>0 S DGEFDT=+$O(^DIC(45.68,DGSUFPTR,"E","B",DGEFDT)),DGEFDT=-DGEFDT
27 S DGEFIEN=$O(^DIC(45.68,DGSUFPTR,"E","AEFF",DGEFDT,DGEFIEN))
28 S DGACT=$P($G(^DIC(45.68,+DGSUFPTR,"E",+DGEFIEN,0)),U,2)
29 Q +$G(DGACT)
30 ;
31ACTLST(DGADM) ; List of active suffixes
32 ;
33 ; DGEFFDT -- Suffix Effective Date
34 ; DGEFFIEN -- Suffix Effective Date IEN
35 ;
36 ; INPUT: DGADM -- PTF IEN (use to get 2nd piece which is
37 ; admission date or use DT if null)
38 ; OUTPUT: List of active suffixes during admission date
39 ;
40 N DGCTR,DGEFFDT,DGEFFIEN,DGI,DGOUT,DGST,DGX,DGY
41 S (DGEFFDT,DGOUT)=0,DGCTR=1
42 I $D(^DGPT(+$G(DGADM),0)) S DGADM=+$P(^(0),U,2)
43 S DGADM=$S(+$G(DGADM)>0:-DGADM,1:-DT) S:$P(DGADM,".",2) DGADM=$P(DGADM,".")
44 F DGST=0:0 S DGST=$O(^DIC(45.81,"B",DGST)) Q:'DGST D
45 .F DGI=0:0 S DGI=$O(^DIC(45.81,DGST,"S","B",DGI)) Q:'DGI D
46 ..S DGEFFDT=+$O(^DIC(45.68,DGI,"E","AEFF",DGADM))
47 ..I -(DGEFFDT)'>0 S DGEFFDT=$O(^DIC(45.68,DGI,"E","B",DGEFFDT)),DGEFFDT=-DGEFFDT
48 ..S DGEFFIEN=0,DGEFFIEN=$O(^DIC(45.68,DGI,"E","AEFF",DGEFFDT,DGEFFIEN))
49 ..S:$P($G(^DIC(45.68,DGI,"E",+DGEFFIEN,0)),U,2)=1 ^TMP("ACTSUFF",$J,DGCTR)=$P($G(^DIC(45.68,DGI,0)),U)_U_$P($G(^DIC(45.81,DGST,0)),U,2),DGCTR=DGCTR+1
50 W @IOF,"Choose From:",!
51 F DGX=0:0 S DGX=$O(^TMP("ACTSUFF",$J,DGX)) Q:'DGX!($G(DGOUT)) D
52 .I $Y>(IOSL-5) D NEXTSCR
53 .W:'$G(DGOUT) !,$P($G(^TMP("ACTSUFF",$J,DGX)),U),?15,$P($G(^TMP("ACTSUFF",$J,DGX)),U,2)
54 K ^TMP("ACTSUFF")
55 Q
56NEXTSCR ;
57 F DGY=$Y:1:(IOSL-4) W !
58 S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) S DGOUT=1 K DIRUT,DTOUT,DUOUT G NEXTSCRQ
59 W @IOF,"Choose From:",!
60NEXTSCRQ ;
61 Q
Note: See TracBrowser for help on using the repository browser.