| [613] | 1 | DGPTDD ;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 | ;
|
|---|
| 7 | ACTIVE(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 | ;
|
|---|
| 31 | ACTLST(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
|
|---|
| 56 | NEXTSCR ;
|
|---|
| 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:",!
|
|---|
| 60 | NEXTSCRQ ;
|
|---|
| 61 | Q
|
|---|
