- ANSEAD3 ;IHS/OIRM/DSD/CSC - ENTER/EDIT ADMISSIONS/DISCHARGES; [ 02/25/98 10:32 AM ]
- ;;3.0;NURSING PATIENT ACUITY;;APR 01, 1996
- ;;ADD/EDIT ADMISSIONS & DISCHARGES
- D HEAD
- S X=$P(^DPT(ANSDFN,0),U)
- W !!,$P(X,","),", ",$P(X,",",2,99)
- I ANSSITE,$D(^AUPNPAT(ANSDFN,41,ANSSITE,0)) S X=$P(^(0),U,2) I X]"" W " (",X,")"
- D DISP
- A1 S DIR(0)="YO",DIR("A")="DELETE the Entire Admission",DIR("B")="NO",DIR("?")="You may delete this admission and all of it's associated data."
- D DIR^ANSDIC
- Q:$D(DTOUT)!$D(DUOUT)
- I Y'=1 D B0 Q
- W *7
- A2 S DIR(0)="YO",DIR("A",1)="This Admission and all of the associated Acuity data will be deleted.",DIR("A")="Are You certain you want to do this",DIR("B")="YES"
- D DIR^ANSDIC
- Q:$D(DTOUT)!$D(DUOUT)!($G(Y)'=1)
- W !!,"Standby..."
- D DEL
- W:$X>60 !
- W " Done."
- Q
- B0 S (L,D)=0,N="" ;CSC 12/19/96 (N="")
- ;I $D(^ANSR("PT",ANSDFN,ANSDA)) G ^ANSEAD1
- Q:$D(^ANSR("PT",ANSDFN,ANSDA))
- S D=9999999-^ANSR(ANSDA,0)
- B1 F S N=$O(^ANSR("AA",ANSDFN,D,N)) Q:N="" S L=N
- Q:L'=ANSDA
- B2 S DIR(0)="YO",DIR("A")="Delete The Discharge",DIR("B")="NO"
- S DIR("?",1)="Because this is the last Admission, you may choose to delete",DIR("?",1)="the Dischage and thus make the Admission 'CURRENT' again."
- D DIR^ANSDIC
- Q:$D(DTOUT)!$D(DUOUT)
- Q:Y'=1
- S (X,D)=""
- S X=$P($D(^ANSR(ANSDA,"DX")),U,5)
- I X,$D(^ANSR(X,0)) S D=+^(0),S=$P(^(0),U,2)
- I 'D W *7,!!,"Unable to delete Discharge." H 3 Q
- S ^ANSR("PT",ANSDFN,ANSDA)=""
- S DA=X,DIK="^ANSR("
- I ANSDA'=X D DIK^ANSDIC K ^ANSR(ANSDA,"AT",D_"."_S,X)
- S:ANSDA=X $P(^ANSR(X,0),U,5)="A"
- S $P(^ANSR(ANSDA,"DX"),U,5)=""
- W !!,"Deleted."
- Q
- DEL S (A,C)=0
- F S A=$O(^ANSR(ANSDA,"AT",A)) Q:A="" D
- .S B=0
- .S B=$O(^ANSR(ANSDA,"AT",A,B)) Q:B="" D:$D(^ANSR(B,0))
- ..S X=^ANSR(B,0),C=C+1,D=+X
- ..S DA=B,DIK="^ANSR("
- ..D DIK^ANSDIC
- I $D(^ANSR("PT",ANSDFN,ANSDA)) K ^(ANSDA)
- S D=0
- I $D(^ANSR(ANSDA,0)) S DA=ANSDA,DIK="^ANSR(" D DIK^ANSDIC
- Q
- DAT S Y=""
- Q:X'?7N
- S Y=$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(X,4,5))_" "_($E(X,6,7))_", "_($E(X,1,3)+1700)
- Q
- HEAD W @IOF
- S X=$P(ANSPAR,U,2)
- W ?80-$L(X)\2,X,!,?28,"ADMIT/DISCHARGE PATIENTS",!!
- Q
- DISP Q:'$D(^ANSR(ANSDA,0))
- S A=^ANSR(ANSDA,0),B=$G(^("DX"))
- S Y=$P(A,U)
- Q:'Y
- X ^DD("DD")
- W !!,"Admitted On"," ",Y
- S X=$P(B,U,5)
- I 'X W " (Active Inpatient)" Q
- I $D(^ANSR(X,0)) S X=$P(^(0),U) I Y D
- .X ^DD("DD")
- .W " Discharged On ",Y
- Q
- ANSEAD3 ;IHS/OIRM/DSD/CSC - ENTER/EDIT ADMISSIONS/DISCHARGES; [ 02/25/98 10:32 AM ]
- +1 ;;3.0;NURSING PATIENT ACUITY;;APR 01, 1996
- +2 ;;ADD/EDIT ADMISSIONS & DISCHARGES
- +3 DO HEAD
- +4 SET X=$PIECE(^DPT(ANSDFN,0),U)
- +5 WRITE !!,$PIECE(X,","),", ",$PIECE(X,",",2,99)
- +6 IF ANSSITE
- IF $DATA(^AUPNPAT(ANSDFN,41,ANSSITE,0))
- SET X=$PIECE(^(0),U,2)
- IF X]""
- WRITE " (",X,")"
- +7 DO DISP
- A1 SET DIR(0)="YO"
- SET DIR("A")="DELETE the Entire Admission"
- SET DIR("B")="NO"
- SET DIR("?")="You may delete this admission and all of it's associated data."
- +1 DO DIR^ANSDIC
- +2 IF $DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- +3 IF Y'=1
- DO B0
- QUIT
- +4 WRITE *7
- A2 SET DIR(0)="YO"
- SET DIR("A",1)="This Admission and all of the associated Acuity data will be deleted."
- SET DIR("A")="Are You certain you want to do this"
- SET DIR("B")="YES"
- +1 DO DIR^ANSDIC
- +2 IF $DATA(DTOUT)!$DATA(DUOUT)!($GET(Y)'=1)
- QUIT
- +3 WRITE !!,"Standby..."
- +4 DO DEL
- +5 IF $X>60
- WRITE !
- +6 WRITE " Done."
- +7 QUIT
- B0 ;CSC 12/19/96 (N="")
- SET (L,D)=0
- SET N=""
- +1 ;I $D(^ANSR("PT",ANSDFN,ANSDA)) G ^ANSEAD1
- +2 IF $DATA(^ANSR("PT",ANSDFN,ANSDA))
- QUIT
- +3 SET D=9999999-^ANSR(ANSDA,0)
- B1 FOR
- SET N=$ORDER(^ANSR("AA",ANSDFN,D,N))
- IF N=""
- QUIT
- SET L=N
- +1 IF L'=ANSDA
- QUIT
- B2 SET DIR(0)="YO"
- SET DIR("A")="Delete The Discharge"
- SET DIR("B")="NO"
- +1 SET DIR("?",1)="Because this is the last Admission, you may choose to delete"
- SET DIR("?",1)="the Dischage and thus make the Admission 'CURRENT' again."
- +2 DO DIR^ANSDIC
- +3 IF $DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- +4 IF Y'=1
- QUIT
- +5 SET (X,D)=""
- +6 SET X=$PIECE($DATA(^ANSR(ANSDA,"DX")),U,5)
- +7 IF X
- IF $DATA(^ANSR(X,0))
- SET D=+^(0)
- SET S=$PIECE(^(0),U,2)
- +8 IF 'D
- WRITE *7,!!,"Unable to delete Discharge."
- HANG 3
- QUIT
- +9 SET ^ANSR("PT",ANSDFN,ANSDA)=""
- +10 SET DA=X
- SET DIK="^ANSR("
- +11 IF ANSDA'=X
- DO DIK^ANSDIC
- KILL ^ANSR(ANSDA,"AT",D_"."_S,X)
- +12 IF ANSDA=X
- SET $PIECE(^ANSR(X,0),U,5)="A"
- +13 SET $PIECE(^ANSR(ANSDA,"DX"),U,5)=""
- +14 WRITE !!,"Deleted."
- +15 QUIT
- DEL SET (A,C)=0
- +1 FOR
- SET A=$ORDER(^ANSR(ANSDA,"AT",A))
- IF A=""
- QUIT
- Begin DoDot:1
- +2 SET B=0
- +3 SET B=$ORDER(^ANSR(ANSDA,"AT",A,B))
- IF B=""
- QUIT
- IF $DATA(^ANSR(B,0))
- Begin DoDot:2
- +4 SET X=^ANSR(B,0)
- SET C=C+1
- SET D=+X
- +5 SET DA=B
- SET DIK="^ANSR("
- +6 DO DIK^ANSDIC
- End DoDot:2
- End DoDot:1
- +7 IF $DATA(^ANSR("PT",ANSDFN,ANSDA))
- KILL ^(ANSDA)
- +8 SET D=0
- +9 IF $DATA(^ANSR(ANSDA,0))
- SET DA=ANSDA
- SET DIK="^ANSR("
- DO DIK^ANSDIC
- +10 QUIT
- DAT SET Y=""
- +1 IF X'?7N
- QUIT
- +2 SET Y=$PIECE("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$EXTRACT(X,4,5))_" "_($EXTRACT(X,6,7))_", "_($EXTRACT(X,1,3)+1700)
- +3 QUIT
- HEAD WRITE @IOF
- +1 SET X=$PIECE(ANSPAR,U,2)
- +2 WRITE ?80-$LENGTH(X)\2,X,!,?28,"ADMIT/DISCHARGE PATIENTS",!!
- +3 QUIT
- DISP IF '$DATA(^ANSR(ANSDA,0))
- QUIT
- +1 SET A=^ANSR(ANSDA,0)
- SET B=$GET(^("DX"))
- +2 SET Y=$PIECE(A,U)
- +3 IF 'Y
- QUIT
- +4 XECUTE ^DD("DD")
- +5 WRITE !!,"Admitted On"," ",Y
- +6 SET X=$PIECE(B,U,5)
- +7 IF 'X
- WRITE " (Active Inpatient)"
- QUIT
- +8 IF $DATA(^ANSR(X,0))
- SET X=$PIECE(^(0),U)
- IF Y
- Begin DoDot:1
- +9 XECUTE ^DD("DD")
- +10 WRITE " Discharged On ",Y
- End DoDot:1
- +11 QUIT
