- 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
