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
