- ADGAD0 ; IHS/ADC/PDW/ENM - A&D UTILITIES ; [ 03/29/1999 8:51 AM ]
- ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- ;
- ; PD (previous date) used by VA G&L routines.
- ;
- E ; -- error processor
- Q
- ;
- FORMAT ;EP; -- format
- N DIR,Y
- K DIR S DIR(0)="SB^D:Detailed Format;S:Summary Format"
- S DIR("A")="Select Report Format - DETAILED or SUMMARY"
- HLP S DIR("?",1)="DETAILED FORMAT uses a right margin of 110."
- S DIR("?",2)="It lists each patient name along with provider, age,"
- S DIR("?",3)="ward, service, community, and chart number."
- S DIR("?",4)="Newborn admissions and discharges are listed separately."
- S DIR("?",5)=" "
- S DIR("?",6)="SUMMARY FORMAT uses a right margin of 80."
- S DIR("?",7)="It gives a summary of movements by service."
- S DIR("?",8)="Then lists each patient with chart number, service,"
- S DIR("?",9)="and ward.",DIR("?",10)=" "
- S DIR("?")="Enter 'D' for DETAILED or 'S' for SUMMARY"
- D ^DIR G FORMAT:Y=-1 S DGZFM=Y
- I Y="D" W !!?20,"Paper margin must be at least 110."
- Q
- ;
- MAN ; -- manual purge
- N Y,X,X1,X2,%DT,DIR
- ; -- date selection
- S %DT="AEPX",%DT("A")="Purge from what date: " D ^%DT K %DT
- G:Y=-1 MAN Q:$D(DTOUT) S PD=Y
- ; -- procede?
- W !!,"Do you want to purge census file from " X ^DD("DD") W Y
- S DIR(0)="Y",DIR("A")="PURGE",DIR("B")="NO" D ^DIR
- ; -- call prg
- I 'Y K PD Q
- S X1=PD,X2=-1 D C^%DTC S PD=X
- D PRG K PD Q
- ;
- PRG ;EP; -- purge (PD, (purge date)-1, required) called from recalc
- ; -- adgwd (ward)
- N W,T,D
- S W=0 F S W=$O(^ADGWD(W)) Q:'W D
- . S:$P($G(^ADGWD(W,1,0)),U,2)="" $P(^(0),U,2)="9009011.01D"
- . S D=RC F S D=$O(^ADGWD(W,1,D)) Q:'D D
- .. S DA(1)=W,DA=D,DIK="^ADGWD("_DA(1)_",1," D ^DIK K DA,DIK
- ; -- adgtx (ts)
- S T=0 F S T=$O(^ADGTX(T)) Q:'T D
- . S:$P($G(^ADGTX(T,1,0)),U,2)="" $P(^(0),U,2)="9009011.51D"
- . S D=RC F S D=$O(^ADGTX(T,1,D)) Q:'D D
- .. S DA(1)=T,DA=D,DIK="^ADGTX("_DA(1)_",1," D ^DIK K DA,DIK
- Q
- OLDPRG ;IHS/DSD/ENM 03/16/99 PRG MODULE COPIED/MODIFIED
- ;EP; -- purge (PD, (purge date)-1, required) called from recalc
- ; -- adgwd (ward)
- N W,T,D
- S W=0 F S W=$O(^ADGWD(W)) Q:'W D
- . S:$P($G(^ADGWD(W,1,0)),U,2)="" $P(^(0),U,2)="9009011.01D"
- . S D=PD F S D=$O(^ADGWD(W,1,D)) Q:'D D
- .. S DA(1)=W,DA=D,DIK="^ADGWD("_DA(1)_",1," N W,D D ^DIK K DA,DIK
- ; -- adgtx (ts)
- S T=0 F S T=$O(^ADGTX(T)) Q:'T D
- . S:$P($G(^ADGTX(T,1,0)),U,2)="" $P(^(0),U,2)="9009011.51D"
- . S D=PD F S D=$O(^ADGTX(T,1,D)) Q:'D D
- .. S DA(1)=T,DA=D,DIK="^ADGTX("_DA(1)_",1," N T,D D ^DIK K DA,DIK
- Q
- ADGAD0 ; IHS/ADC/PDW/ENM - A&D UTILITIES ; [ 03/29/1999 8:51 AM ]
- +1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
- +2 ;
- +3 ; PD (previous date) used by VA G&L routines.
- +4 ;
- E ; -- error processor
- +1 QUIT
- +2 ;
- FORMAT ;EP; -- format
- +1 NEW DIR,Y
- +2 KILL DIR
- SET DIR(0)="SB^D:Detailed Format;S:Summary Format"
- +3 SET DIR("A")="Select Report Format - DETAILED or SUMMARY"
- HLP SET DIR("?",1)="DETAILED FORMAT uses a right margin of 110."
- +1 SET DIR("?",2)="It lists each patient name along with provider, age,"
- +2 SET DIR("?",3)="ward, service, community, and chart number."
- +3 SET DIR("?",4)="Newborn admissions and discharges are listed separately."
- +4 SET DIR("?",5)=" "
- +5 SET DIR("?",6)="SUMMARY FORMAT uses a right margin of 80."
- +6 SET DIR("?",7)="It gives a summary of movements by service."
- +7 SET DIR("?",8)="Then lists each patient with chart number, service,"
- +8 SET DIR("?",9)="and ward."
- SET DIR("?",10)=" "
- +9 SET DIR("?")="Enter 'D' for DETAILED or 'S' for SUMMARY"
- +10 DO ^DIR
- IF Y=-1
- GOTO FORMAT
- SET DGZFM=Y
- +11 IF Y="D"
- WRITE !!?20,"Paper margin must be at least 110."
- +12 QUIT
- +13 ;
- MAN ; -- manual purge
- +1 NEW Y,X,X1,X2,%DT,DIR
- +2 ; -- date selection
- +3 SET %DT="AEPX"
- SET %DT("A")="Purge from what date: "
- DO ^%DT
- KILL %DT
- +4 IF Y=-1
- GOTO MAN
- IF $DATA(DTOUT)
- QUIT
- SET PD=Y
- +5 ; -- procede?
- +6 WRITE !!,"Do you want to purge census file from "
- XECUTE ^DD("DD")
- WRITE Y
- +7 SET DIR(0)="Y"
- SET DIR("A")="PURGE"
- SET DIR("B")="NO"
- DO ^DIR
- +8 ; -- call prg
- +9 IF 'Y
- KILL PD
- QUIT
- +10 SET X1=PD
- SET X2=-1
- DO C^%DTC
- SET PD=X
- +11 DO PRG
- KILL PD
- QUIT
- +12 ;
- PRG ;EP; -- purge (PD, (purge date)-1, required) called from recalc
- +1 ; -- adgwd (ward)
- +2 NEW W,T,D
- +3 SET W=0
- FOR
- SET W=$ORDER(^ADGWD(W))
- IF 'W
- QUIT
- Begin DoDot:1
- +4 IF $PIECE($GET(^ADGWD(W,1,0)),U,2)=""
- SET $PIECE(^(0),U,2)="9009011.01D"
- +5 SET D=RC
- FOR
- SET D=$ORDER(^ADGWD(W,1,D))
- IF 'D
- QUIT
- Begin DoDot:2
- +6 SET DA(1)=W
- SET DA=D
- SET DIK="^ADGWD("_DA(1)_",1,"
- DO ^DIK
- KILL DA,DIK
- End DoDot:2
- End DoDot:1
- +7 ; -- adgtx (ts)
- +8 SET T=0
- FOR
- SET T=$ORDER(^ADGTX(T))
- IF 'T
- QUIT
- Begin DoDot:1
- +9 IF $PIECE($GET(^ADGTX(T,1,0)),U,2)=""
- SET $PIECE(^(0),U,2)="9009011.51D"
- +10 SET D=RC
- FOR
- SET D=$ORDER(^ADGTX(T,1,D))
- IF 'D
- QUIT
- Begin DoDot:2
- +11 SET DA(1)=T
- SET DA=D
- SET DIK="^ADGTX("_DA(1)_",1,"
- DO ^DIK
- KILL DA,DIK
- End DoDot:2
- End DoDot:1
- +12 QUIT
- OLDPRG ;IHS/DSD/ENM 03/16/99 PRG MODULE COPIED/MODIFIED
- +1 ;EP; -- purge (PD, (purge date)-1, required) called from recalc
- +2 ; -- adgwd (ward)
- +3 NEW W,T,D
- +4 SET W=0
- FOR
- SET W=$ORDER(^ADGWD(W))
- IF 'W
- QUIT
- Begin DoDot:1
- +5 IF $PIECE($GET(^ADGWD(W,1,0)),U,2)=""
- SET $PIECE(^(0),U,2)="9009011.01D"
- +6 SET D=PD
- FOR
- SET D=$ORDER(^ADGWD(W,1,D))
- IF 'D
- QUIT
- Begin DoDot:2
- +7 SET DA(1)=W
- SET DA=D
- SET DIK="^ADGWD("_DA(1)_",1,"
- NEW W,D
- DO ^DIK
- KILL DA,DIK
- End DoDot:2
- End DoDot:1
- +8 ; -- adgtx (ts)
- +9 SET T=0
- FOR
- SET T=$ORDER(^ADGTX(T))
- IF 'T
- QUIT
- Begin DoDot:1
- +10 IF $PIECE($GET(^ADGTX(T,1,0)),U,2)=""
- SET $PIECE(^(0),U,2)="9009011.51D"
- +11 SET D=PD
- FOR
- SET D=$ORDER(^ADGTX(T,1,D))
- IF 'D
- QUIT
- Begin DoDot:2
- +12 SET DA(1)=T
- SET DA=D
- SET DIK="^ADGTX("_DA(1)_",1,"
- NEW T,D
- DO ^DIK
- KILL DA,DIK
- End DoDot:2
- End DoDot:1
- +13 QUIT
