DGPTDD ;ALB/LD - DD calls for Suffix fields of PTF file; 27 May 1995
;;5.3;Registration;**58,1015**;Aug 13, 1993;Build 21
;
; DD calls for the Suffix and Transferring Suffix fields of PTF
; file (#45).
;
ACTIVE(X,Y,DGADM) ; Suffix active during patient's admission date?
;
; DGEFDT -- Suffix Effective Date
; DGEFIEN -- Suffix Effective Date IEN
; DGSUFPTR -- Suffix pointer from Station Type file
;
; INPUT: X -- Suffix
; Y -- Station Type Number
; DGADM -- PTF IEN (use to get 2nd piece which is
; admission date or use DT if null)
; OUTPUT: DGACT -- Active during admission date? (1=YES,0=NO)
;
N DGACT,DGEFDT,DGEFIEN,DGFL,DGSUFPTR,DGI
S (DGACT,DGEFIEN,DGEFDT,DGFL,DGSUFPTR)=0
F DGI=0:0 S DGI=$O(^DIC(45.81,+$G(Y),"S","B",DGI)) Q:'DGI!$G(DGFL) D
.I $P($G(^DIC(45.68,DGI,0)),U)=$G(X) S DGSUFPTR=DGI,DGFL=1
I $D(^DGPT(+$G(DGADM),0)) S DGADM=+$P(^(0),U,2)
S DGADM=$S(+$G(DGADM)>0:-DGADM,1:-DT) S:$P(DGADM,".",2) DGADM=$P(DGADM,".") S DGADM=DGADM_.2359
S DGEFDT=+$O(^DIC(45.68,DGSUFPTR,"E","AEFF",DGADM))
I -(DGEFDT)'>0 S DGEFDT=+$O(^DIC(45.68,DGSUFPTR,"E","B",DGEFDT)),DGEFDT=-DGEFDT
S DGEFIEN=$O(^DIC(45.68,DGSUFPTR,"E","AEFF",DGEFDT,DGEFIEN))
S DGACT=$P($G(^DIC(45.68,+DGSUFPTR,"E",+DGEFIEN,0)),U,2)
Q +$G(DGACT)
;
ACTLST(DGADM) ; List of active suffixes
;
; DGEFFDT -- Suffix Effective Date
; DGEFFIEN -- Suffix Effective Date IEN
;
; INPUT: DGADM -- PTF IEN (use to get 2nd piece which is
; admission date or use DT if null)
; OUTPUT: List of active suffixes during admission date
;
N DGCTR,DGEFFDT,DGEFFIEN,DGI,DGOUT,DGST,DGX,DGY
S (DGEFFDT,DGOUT)=0,DGCTR=1
I $D(^DGPT(+$G(DGADM),0)) S DGADM=+$P(^(0),U,2)
S DGADM=$S(+$G(DGADM)>0:-DGADM,1:-DT) S:$P(DGADM,".",2) DGADM=$P(DGADM,".")
F DGST=0:0 S DGST=$O(^DIC(45.81,"B",DGST)) Q:'DGST D
.F DGI=0:0 S DGI=$O(^DIC(45.81,DGST,"S","B",DGI)) Q:'DGI D
..S DGEFFDT=+$O(^DIC(45.68,DGI,"E","AEFF",DGADM))
..I -(DGEFFDT)'>0 S DGEFFDT=$O(^DIC(45.68,DGI,"E","B",DGEFFDT)),DGEFFDT=-DGEFFDT
..S DGEFFIEN=0,DGEFFIEN=$O(^DIC(45.68,DGI,"E","AEFF",DGEFFDT,DGEFFIEN))
..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
W @IOF,"Choose From:",!
F DGX=0:0 S DGX=$O(^TMP("ACTSUFF",$J,DGX)) Q:'DGX!($G(DGOUT)) D
.I $Y>(IOSL-5) D NEXTSCR
.W:'$G(DGOUT) !,$P($G(^TMP("ACTSUFF",$J,DGX)),U),?15,$P($G(^TMP("ACTSUFF",$J,DGX)),U,2)
K ^TMP("ACTSUFF")
Q
NEXTSCR ;
F DGY=$Y:1:(IOSL-4) W !
S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) S DGOUT=1 K DIRUT,DTOUT,DUOUT G NEXTSCRQ
W @IOF,"Choose From:",!
NEXTSCRQ ;
Q
DGPTDD ;ALB/LD - DD calls for Suffix fields of PTF file; 27 May 1995
+1 ;;5.3;Registration;**58,1015**;Aug 13, 1993;Build 21
+2 ;
+3 ; DD calls for the Suffix and Transferring Suffix fields of PTF
+4 ; file (#45).
+5 ;
ACTIVE(X,Y,DGADM) ; Suffix active during patient's admission date?
+1 ;
+2 ; DGEFDT -- Suffix Effective Date
+3 ; DGEFIEN -- Suffix Effective Date IEN
+4 ; DGSUFPTR -- Suffix pointer from Station Type file
+5 ;
+6 ; INPUT: X -- Suffix
+7 ; Y -- Station Type Number
+8 ; DGADM -- PTF IEN (use to get 2nd piece which is
+9 ; admission date or use DT if null)
+10 ; OUTPUT: DGACT -- Active during admission date? (1=YES,0=NO)
+11 ;
+12 NEW DGACT,DGEFDT,DGEFIEN,DGFL,DGSUFPTR,DGI
+13 SET (DGACT,DGEFIEN,DGEFDT,DGFL,DGSUFPTR)=0
+14 FOR DGI=0:0
SET DGI=$ORDER(^DIC(45.81,+$GET(Y),"S","B",DGI))
IF 'DGI!$GET(DGFL)
QUIT
Begin DoDot:1
+15 IF $PIECE($GET(^DIC(45.68,DGI,0)),U)=$GET(X)
SET DGSUFPTR=DGI
SET DGFL=1
End DoDot:1
+16 IF $DATA(^DGPT(+$GET(DGADM),0))
SET DGADM=+$PIECE(^(0),U,2)
+17 SET DGADM=$SELECT(+$GET(DGADM)>0:-DGADM,1:-DT)
IF $PIECE(DGADM,".",2)
SET DGADM=$PIECE(DGADM,".")
SET DGADM=DGADM_.2359
+18 SET DGEFDT=+$ORDER(^DIC(45.68,DGSUFPTR,"E","AEFF",DGADM))
+19 IF -(DGEFDT)'>0
SET DGEFDT=+$ORDER(^DIC(45.68,DGSUFPTR,"E","B",DGEFDT))
SET DGEFDT=-DGEFDT
+20 SET DGEFIEN=$ORDER(^DIC(45.68,DGSUFPTR,"E","AEFF",DGEFDT,DGEFIEN))
+21 SET DGACT=$PIECE($GET(^DIC(45.68,+DGSUFPTR,"E",+DGEFIEN,0)),U,2)
+22 QUIT +$GET(DGACT)
+23 ;
ACTLST(DGADM) ; List of active suffixes
+1 ;
+2 ; DGEFFDT -- Suffix Effective Date
+3 ; DGEFFIEN -- Suffix Effective Date IEN
+4 ;
+5 ; INPUT: DGADM -- PTF IEN (use to get 2nd piece which is
+6 ; admission date or use DT if null)
+7 ; OUTPUT: List of active suffixes during admission date
+8 ;
+9 NEW DGCTR,DGEFFDT,DGEFFIEN,DGI,DGOUT,DGST,DGX,DGY
+10 SET (DGEFFDT,DGOUT)=0
SET DGCTR=1
+11 IF $DATA(^DGPT(+$GET(DGADM),0))
SET DGADM=+$PIECE(^(0),U,2)
+12 SET DGADM=$SELECT(+$GET(DGADM)>0:-DGADM,1:-DT)
IF $PIECE(DGADM,".",2)
SET DGADM=$PIECE(DGADM,".")
+13 FOR DGST=0:0
SET DGST=$ORDER(^DIC(45.81,"B",DGST))
IF 'DGST
QUIT
Begin DoDot:1
+14 FOR DGI=0:0
SET DGI=$ORDER(^DIC(45.81,DGST,"S","B",DGI))
IF 'DGI
QUIT
Begin DoDot:2
+15 SET DGEFFDT=+$ORDER(^DIC(45.68,DGI,"E","AEFF",DGADM))
+16 IF -(DGEFFDT)'>0
SET DGEFFDT=$ORDER(^DIC(45.68,DGI,"E","B",DGEFFDT))
SET DGEFFDT=-DGEFFDT
+17 SET DGEFFIEN=0
SET DGEFFIEN=$ORDER(^DIC(45.68,DGI,"E","AEFF",DGEFFDT,DGEFFIEN))
+18 IF $PIECE($GET(^DIC(45.68,DGI,"E",+DGEFFIEN,0)),U,2)=1
SET ^TMP("ACTSUFF",$JOB,DGCTR)=$PIECE($GET(^DIC(45.68,DGI,0)),U)_U_$PIECE($GET(^DIC(45.81,DGST,0)),U,2)
SET DGCTR=DGCTR+1
End DoDot:2
End DoDot:1
+19 WRITE @IOF,"Choose From:",!
+20 FOR DGX=0:0
SET DGX=$ORDER(^TMP("ACTSUFF",$JOB,DGX))
IF 'DGX!($GET(DGOUT))
QUIT
Begin DoDot:1
+21 IF $Y>(IOSL-5)
DO NEXTSCR
+22 IF '$GET(DGOUT)
WRITE !,$PIECE($GET(^TMP("ACTSUFF",$JOB,DGX)),U),?15,$PIECE($GET(^TMP("ACTSUFF",$JOB,DGX)),U,2)
End DoDot:1
+23 KILL ^TMP("ACTSUFF")
+24 QUIT
NEXTSCR ;
+1 FOR DGY=$Y:1:(IOSL-4)
WRITE !
+2 SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!($DATA(DUOUT))
SET DGOUT=1
KILL DIRUT,DTOUT,DUOUT
GOTO NEXTSCRQ
+3 WRITE @IOF,"Choose From:",!
NEXTSCRQ ;
+1 QUIT
