- HBHCDIS ;LR VAMC(IRMS)/MJT - HBHC Discharge data entry, calls STATUS^HBHCUTL from [HBHC DISCHARGE] template ;3/18/14
- ;;1.0;HOSPITAL BASED HOME CARE;**2,25**;NOV 01, 1993;Build 45
- ;
- ; Reference to $$SINFO^ICDEX supported by ICR #5747
- ; $$SINFO^ICDEX is called from the [HBHC DISCHARGE] input template
- ;
- START ; Initialization
- S HBHCFORM=5
- PROMPT ; Prompt user for patient name
- K DIC,HBHCPRCT S DIC="^HBHC(631,",DIC(0)="AEMQZ" D ^DIC
- G:Y=-1 EXIT
- I $P(Y(0),U,15)'=1 W *7,!!,"Record indicates patient has not been admitted to HBHC. Discharge not allowed",!,"without admission.",! H 3 G PROMPT
- S HBHCDFN=+Y,HBHCDPT=$P(Y,U,2),HBHCXMT5=$P($G(^HBHC(631,HBHCDFN,1)),U,18)
- I (HBHCXMT5]"")&(HBHCXMT5'="N") D FORMMSG^HBHCUTL1 G:$D(HBHCNHSP) EXIT G:HBHCPRCT'=1 PROMPT
- K DIE S DIE="^HBHC(631,",DA=HBHCDFN,DR="[HBHC DISCHARGE]"
- L +^HBHC(631,HBHCDFN):0 I $T D ^DIE L -^HBHC(631,HBHCDFN) G PROMPT
- W *7,!!,"Another user is editing this entry.",!! G PROMPT
- EXIT ; Exit module
- K DA,DIC,DIE,DR,HBHC12,HBHC359,HBHCDFLG,HBHCDFN,HBHCDIED,HBHCDPT,HBHCFORM,HBHCI,HBHCJ,HBHCL,HBHCM,HBHCNHSP,HBHCNOD1,HBHCPRCT,HBHCQ,HBHCQ1,HBHCTFLG,HBHCXMT5,HBHCWRD1,HBHCWRD2,HBHCWRD3,HBHCY0,X,Y
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCDIS 1190 printed Jan 18, 2025@02:59:13 Page 2
- HBHCDIS ;LR VAMC(IRMS)/MJT - HBHC Discharge data entry, calls STATUS^HBHCUTL from [HBHC DISCHARGE] template ;3/18/14
- +1 ;;1.0;HOSPITAL BASED HOME CARE;**2,25**;NOV 01, 1993;Build 45
- +2 ;
- +3 ; Reference to $$SINFO^ICDEX supported by ICR #5747
- +4 ; $$SINFO^ICDEX is called from the [HBHC DISCHARGE] input template
- +5 ;
- START ; Initialization
- +1 SET HBHCFORM=5
- PROMPT ; Prompt user for patient name
- +1 KILL DIC,HBHCPRCT
- SET DIC="^HBHC(631,"
- SET DIC(0)="AEMQZ"
- DO ^DIC
- +2 if Y=-1
- GOTO EXIT
- +3 IF $PIECE(Y(0),U,15)'=1
- WRITE *7,!!,"Record indicates patient has not been admitted to HBHC. Discharge not allowed",!,"without admission.",!
- HANG 3
- GOTO PROMPT
- +4 SET HBHCDFN=+Y
- SET HBHCDPT=$PIECE(Y,U,2)
- SET HBHCXMT5=$PIECE($GET(^HBHC(631,HBHCDFN,1)),U,18)
- +5 IF (HBHCXMT5]"")&(HBHCXMT5'="N")
- DO FORMMSG^HBHCUTL1
- if $DATA(HBHCNHSP)
- GOTO EXIT
- if HBHCPRCT'=1
- GOTO PROMPT
- +6 KILL DIE
- SET DIE="^HBHC(631,"
- SET DA=HBHCDFN
- SET DR="[HBHC DISCHARGE]"
- +7 LOCK +^HBHC(631,HBHCDFN):0
- IF $TEST
- DO ^DIE
- LOCK -^HBHC(631,HBHCDFN)
- GOTO PROMPT
- +8 WRITE *7,!!,"Another user is editing this entry.",!!
- GOTO PROMPT
- EXIT ; Exit module
- +1 KILL DA,DIC,DIE,DR,HBHC12,HBHC359,HBHCDFLG,HBHCDFN,HBHCDIED,HBHCDPT,HBHCFORM,HBHCI,HBHCJ,HBHCL,HBHCM,HBHCNHSP,HBHCNOD1,HBHCPRCT,HBHCQ,HBHCQ1,HBHCTFLG,HBHCXMT5,HBHCWRD1,HBHCWRD2,HBHCWRD3,HBHCY0,X,Y
- +2 QUIT