- HBHCADM ;LR VAMC(IRMS)/MJT - HBHC eval/admit data entry; Apr 29, 2021@07:55
- ;;1.0;HOSPITAL BASED HOME CARE;**2,6,8,16,24,25,32,35**;NOV 01, 1993;Build 1
- ;
- ; Reference to $$SINFO^ICDEX supported by ICR #5747
- ; Reference to ^DG(40.8 supported by ICR #7024
- ;
- ;This routine appears to have locking flaws in that there is no allowance for
- ;locking failure. Any flaws will be researched and addressed in a future patch.
- ;HBH*1.0*32 is following the pattern of how HBHCADM currently locks records.
- ;
- START ; Initialization
- ;Sites must have at least one parent site defined.
- I $O(^HBHC(631.9,1,1,"B",""))="" D Q
- . W !!,"No parent sites are defined at this facility."
- . W !,"Contact your HBPC Program Manager to define at least one"
- . W !,"parent site in option ""System Parameters Edit"".",!
- . N DIR
- . S DIR("A")="Press any key to continue",DIR(0)="FO"
- . D ^DIR
- S HBHCFORM=3
- ;Variable HBHCMFHS is set if this site is a
- ;sanctioned Medical Foster Home site.
- D MFHS^HBHCUTL3
- PROMPT ; Prompt user for patient name
- N HBHCHOSP
- S HBHCHOSP=$P(^HBHC(631.9,1,0),U,5)
- K DIC,HBHCFLG,HBHCPRCT S DIC="^HBHC(631,",DIC(0)="AELMQZ" D ^DIC
- G:Y=-1 EXIT
- S HBHCDFN=+Y,HBHCDPT=$P(Y,U,2),HBHCDPT0=^DPT(HBHCDPT,0),HBHCNOD0=Y(0)
- I $P(HBHCDPT0,U,9)'?9N W !!,"Patient has 'pseudo' social security number (SSN) on file. If patient was",!,"not chosen in error, contact MAS to correct the invalid SSN. Patient must",!,"have a valid SSN to be selected.",! H 3 G PROMPT
- S HBHCXMT3=$P($G(^HBHC(631,HBHCDFN,1)),U,17)
- I $P(^HBHC(631,HBHCDFN,0),U,40)]"" W $C(7),!!!,"*** Record contains Discharge data indicating a Complete Episode of Care ***",!! H 3
- I (HBHCXMT3]"")&(HBHCXMT3'="N") D FORMMSG^HBHCUTL1 G:$D(HBHCNHSP) EXIT G:HBHCPRCT'=1 PROMPT
- I $P(Y,U,3) S $P(^HBHC(631,HBHCDFN,1),U,17)="N",^HBHC(631,"AE","N",HBHCDFN)="" S HBHCBXRF="" F S HBHCBXRF=$O(^HBHC(631,"B",HBHCDPT,HBHCBXRF)) Q:(HBHCBXRF="")!(HBHCBXRF=HBHCDFN) D CHECK
- G:$D(HBHCFLG) PROMPT
- ;
- MFH ;HBH*1.0*32: first determine if an MFH patient
- ;Variable HBHCFMHS = does this site have Medical Foster Homes
- I $D(HBHCMFHS) D
- . N DIE,DA,DR,HBHCSAVY,HBHCMFHSTR,HBHCMFHX
- . ;preserving "Y" since will be killed downstream
- . M HBHCSAVY=Y
- . S DIE="^HBHC(631,",DA=HBHCDFN
- . S DR(2,631.01)=1,DR="K HBHCQ;88;S:X'=""Y"" Y=""@1"";89;90;@1;"
- . L +^HBHC(631,HBHCDFN):0 I $T D ^DIE
- . M Y=HBHCSAVY
- ;
- MFHNO ;Either the site does not have medical foster homes,
- ;or this patient is not in a medical foster home.
- ;In that case, the Parent Site prompt is presented.
- I $P($G(^HBHC(631,HBHCDFN,3)),"^")'="Y" D
- . ;This section called only if patient is not an MFH patient.
- . ;HBH*1.0*32: add PARENT SITE (#91) field
- . ;set a default if there is only one parent site defined
- . ;at this site
- . N HBHCPARN,HBHCSAVY
- . ;saving original value of Y since used further down by pre-HBH*1.0*32 code
- . M HBHCSAVY=Y
- . S HBHCPARN=$S($P(^HBHC(631.9,1,1,0),"^",4)=1:$O(^HBHC(631.9,1,1,"B","")),1:"")
- . I HBHCPARN]"" S HBHCPARN=$P(^DG(40.8,HBHCPARN,0),"^")
- . S DR="91//^S X=HBHCPARN"
- . S DIE="^HBHC(631,",DA=HBHCDFN
- . L +^HBHC(631,HBHCDFN):0 I $T D ^DIE L -^HBHC(631,HBHCDFN)
- . M Y=HBHCSAVY
- . ;end of HBH*1.0*32
- CONT ;end of MFH logic - continue with prompts, etc.
- ;Parent site is required if not a MFH patient.
- ;Parent site is not required for MFH patients since the MFH's parent site
- ;is retrieved for AITC transmissions.
- N HBHCQUIT
- S HBHCQUIT=1
- ;Is parent site defined - if yes, may continue with prompts.
- I $P($G(^HBHC(631,HBHCDFN,5)),"^")]"" S HBHCQUIT=0
- ;If no parent site and this is an MFH site, the patient needs to be defined
- ;as an MFH patient if there is no parent site in ^HBHC(631,HBHCDFN,5).
- I HBHCQUIT,$D(HBHCMFHS),$P($G(^HBHC(631,HBHCDFN,3)),"^")="Y" S HBHCQUIT=0
- Q:HBHCQUIT
- D DEMO
- K DIE S DIE="^HBHC(631,",DA=HBHCDFN,DIE("NO^")="OUTOK"
- ;added M code for Dx validation based on admission date
- ;added M code for Dx lookup instead of field 18
- S DR="K HBHCQ;17;2:5;D BIRTHYR^HBHCUTL1;7;D SEXRACE^HBHCUTL1;10:13;14;D ACTION^HBHCUTL;15;16"
- L +^HBHC(631,HBHCDFN):0 I $T D ^DIE
- I $D(Y)>0 G PROMPT
- ; For ICD-9 lookups, set key variables used by special lookup routine
- S ICDVDT=$P(^HBHC(631,DA,0),U,18)
- S ICDSYS=+$$SINFO^ICDEX("DIAG",ICDVDT)
- I ICDSYS=1 S ICDFMT=1
- I '$D(HBHCMFHS) D
- .S DR=$S(ICDSYS=1:"I $D(HBHCQ) K HBHCQ S Y=37;18;68;19:36;37:38;67",1:"I $D(HBHCQ) K HBHCQ S Y=37;D ADMDX^HBHCLKU1;68;19:36;37:38;67")
- I $D(HBHCMFHS) D
- .S DR=$S(ICDSYS=1:"I $D(HBHCQ) K HBHCQ S Y=37;18;68;19:36;37:38;67",1:"I $D(HBHCQ) K HBHCQ S Y=37;D ADMDX^HBHCLKU1;68;19:36;37:38;67")
- D ^DIE
- L -^HBHC(631,HBHCDFN) K ICDVDT,ICDSYS,ICDFMT G PROMPT
- W $C(7),!!,"Another user is editing this entry.",!! G PROMPT
- EXIT ; Exit module
- K DA,DIC,DIE,DIK,DR,HBHCAFLG,HBHCBXRF,HBHCCNTY,HBHCDFN,HBHCDPT,HBHCDPT0,HBHCEL,HBHCELGE,HBHCFLG,HBHCFORM,HBHCI,HBHCIEN,HBHCINFO,HBHCJ,HBHCMARE,HBHCMFHS,HBHCMS,HBHCNHSP,HBHCNOD0,HBHCPRCT,HBHCPS,HBHCPSRV,HBHCQ,HBHCRFLG,HBHCST
- K HBHCXMT3,HBHCWRD1,HBHCWRD2,HBHCWRD3,HBHCY0,HBHCZIP,VAEL,X,Y
- Q
- CHECK ; Check previous episode(s) of care for 'Reject' in Admit/Reject Action or Discharge Date to ensure completed episode of care before allowing another episode of care to be created
- Q:($P(^HBHC(631,HBHCBXRF,0),U,15)=2)!($P(^HBHC(631,HBHCBXRF,0),U,40)]"")
- W $C(7),!!,"Patient must be discharged from last episode of care before new episode",!,"can be entered. Current episode not created.",! H 3
- K DIK S DIK="^HBHC(631,",DA=HBHCDFN D ^DIK
- S HBHCFLG=1
- Q
- DEMO ; Obtain patient demographic info
- S (HBHCST,HBHCCNTY,HBHCZIP,HBHCEL,HBHCELGE,HBHCPS,HBHCPSRV,HBHCMS,HBHCMARE)=""
- I $D(^DPT(HBHCDPT,.11)) S HBHCINFO=^DPT(HBHCDPT,.11),HBHCCNTY=$P(HBHCINFO,U,7),HBHCZIP=$P(HBHCINFO,U,12),HBHCST=$P(HBHCINFO,U,5)
- S HBHCIEN="" S:HBHCST HBHCIEN=$O(^HBHC(631.8,"B",HBHCST,HBHCIEN)) S HBHCST=$S($G(HBHCIEN):HBHCIEN,1:"") ;p35
- I $D(^DPT(HBHCDPT,.36)) S DFN=HBHCDPT D ELIG^VADPT S HBHCEL=+VAEL(1),HBHCELGE=$S(HBHCEL=1:"01",HBHCEL=2:"02",HBHCEL=16:"02",HBHCEL=11:"03",HBHCEL=4:"04",1:"05") K DFN
- I $D(^DPT(HBHCDPT,.32)) S HBHCINFO=^DPT(HBHCDPT,.32),HBHCPS=$P(HBHCINFO,U,3),HBHCPSRV=$S(((HBHCPS>0)&(HBHCPS<9)):HBHCPS,HBHCPS=9:10,HBHCPS=121:11,1:"")
- S HBHCINFO=^DPT(HBHCDPT,0),HBHCMS=$P(HBHCINFO,U,5),HBHCMARE=$S(HBHCMS=1:4,HBHCMS=2:1,HBHCMS=4:2,HBHCMS=5:3,HBHCMS=6:5,1:"")
- I HBHCST]"" S:($P(HBHCNOD0,U,3)="")&($D(^HBHC(631.8,HBHCST,0))) $P(^HBHC(631,HBHCDFN,0),U,3)=HBHCST I (HBHCCNTY]"")&($P(HBHCNOD0,U,4)="") S:$D(^HBHC(631.8,HBHCST,0)) $P(^HBHC(631,HBHCDFN,0),U,4)=HBHCCNTY
- S:(HBHCZIP]"")&(($P(HBHCNOD0,U,5)="")!($P(HBHCNOD0,U,5)'?9N)) $P(^HBHC(631,HBHCDFN,0),U,5)=HBHCZIP
- S:(HBHCELGE]"")&($P(HBHCNOD0,U,6)="") $P(^HBHC(631,HBHCDFN,0),U,6)=HBHCELGE
- S:(HBHCPSRV]"")&($P(HBHCNOD0,U,8)="") $P(^HBHC(631,HBHCDFN,0),U,8)=HBHCPSRV
- S:(HBHCMARE]"")&($P(HBHCNOD0,U,11)="") $P(^HBHC(631,HBHCDFN,0),U,11)=HBHCMARE
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCADM 6906 printed Feb 18, 2025@23:24:20 Page 2
- HBHCADM ;LR VAMC(IRMS)/MJT - HBHC eval/admit data entry; Apr 29, 2021@07:55
- +1 ;;1.0;HOSPITAL BASED HOME CARE;**2,6,8,16,24,25,32,35**;NOV 01, 1993;Build 1
- +2 ;
- +3 ; Reference to $$SINFO^ICDEX supported by ICR #5747
- +4 ; Reference to ^DG(40.8 supported by ICR #7024
- +5 ;
- +6 ;This routine appears to have locking flaws in that there is no allowance for
- +7 ;locking failure. Any flaws will be researched and addressed in a future patch.
- +8 ;HBH*1.0*32 is following the pattern of how HBHCADM currently locks records.
- +9 ;
- START ; Initialization
- +1 ;Sites must have at least one parent site defined.
- +2 IF $ORDER(^HBHC(631.9,1,1,"B",""))=""
- Begin DoDot:1
- +3 WRITE !!,"No parent sites are defined at this facility."
- +4 WRITE !,"Contact your HBPC Program Manager to define at least one"
- +5 WRITE !,"parent site in option ""System Parameters Edit"".",!
- +6 NEW DIR
- +7 SET DIR("A")="Press any key to continue"
- SET DIR(0)="FO"
- +8 DO ^DIR
- End DoDot:1
- QUIT
- +9 SET HBHCFORM=3
- +10 ;Variable HBHCMFHS is set if this site is a
- +11 ;sanctioned Medical Foster Home site.
- +12 DO MFHS^HBHCUTL3
- PROMPT ; Prompt user for patient name
- +1 NEW HBHCHOSP
- +2 SET HBHCHOSP=$PIECE(^HBHC(631.9,1,0),U,5)
- +3 KILL DIC,HBHCFLG,HBHCPRCT
- SET DIC="^HBHC(631,"
- SET DIC(0)="AELMQZ"
- DO ^DIC
- +4 if Y=-1
- GOTO EXIT
- +5 SET HBHCDFN=+Y
- SET HBHCDPT=$PIECE(Y,U,2)
- SET HBHCDPT0=^DPT(HBHCDPT,0)
- SET HBHCNOD0=Y(0)
- +6 IF $PIECE(HBHCDPT0,U,9)'?9N
- WRITE !!,"Patient has 'pseudo' social security number (SSN) on file. If patient was",!,"not chosen in error, contact MAS to correct the invalid SSN. Patient must",!,"have a valid SSN to be selected.",!
- HANG 3
- GOTO PROMPT
- +7 SET HBHCXMT3=$PIECE($GET(^HBHC(631,HBHCDFN,1)),U,17)
- +8 IF $PIECE(^HBHC(631,HBHCDFN,0),U,40)]""
- WRITE $CHAR(7),!!!,"*** Record contains Discharge data indicating a Complete Episode of Care ***",!!
- HANG 3
- +9 IF (HBHCXMT3]"")&(HBHCXMT3'="N")
- DO FORMMSG^HBHCUTL1
- if $DATA(HBHCNHSP)
- GOTO EXIT
- if HBHCPRCT'=1
- GOTO PROMPT
- +10 IF $PIECE(Y,U,3)
- SET $PIECE(^HBHC(631,HBHCDFN,1),U,17)="N"
- SET ^HBHC(631,"AE","N",HBHCDFN)=""
- SET HBHCBXRF=""
- FOR
- SET HBHCBXRF=$ORDER(^HBHC(631,"B",HBHCDPT,HBHCBXRF))
- if (HBHCBXRF="")!(HBHCBXRF=HBHCDFN)
- QUIT
- DO CHECK
- +11 if $DATA(HBHCFLG)
- GOTO PROMPT
- +12 ;
- MFH ;HBH*1.0*32: first determine if an MFH patient
- +1 ;Variable HBHCFMHS = does this site have Medical Foster Homes
- +2 IF $DATA(HBHCMFHS)
- Begin DoDot:1
- +3 NEW DIE,DA,DR,HBHCSAVY,HBHCMFHSTR,HBHCMFHX
- +4 ;preserving "Y" since will be killed downstream
- +5 MERGE HBHCSAVY=Y
- +6 SET DIE="^HBHC(631,"
- SET DA=HBHCDFN
- +7 SET DR(2,631.01)=1
- SET DR="K HBHCQ;88;S:X'=""Y"" Y=""@1"";89;90;@1;"
- +8 LOCK +^HBHC(631,HBHCDFN):0
- IF $TEST
- DO ^DIE
- +9 MERGE Y=HBHCSAVY
- End DoDot:1
- +10 ;
- MFHNO ;Either the site does not have medical foster homes,
- +1 ;or this patient is not in a medical foster home.
- +2 ;In that case, the Parent Site prompt is presented.
- +3 IF $PIECE($GET(^HBHC(631,HBHCDFN,3)),"^")'="Y"
- Begin DoDot:1
- +4 ;This section called only if patient is not an MFH patient.
- +5 ;HBH*1.0*32: add PARENT SITE (#91) field
- +6 ;set a default if there is only one parent site defined
- +7 ;at this site
- +8 NEW HBHCPARN,HBHCSAVY
- +9 ;saving original value of Y since used further down by pre-HBH*1.0*32 code
- +10 MERGE HBHCSAVY=Y
- +11 SET HBHCPARN=$SELECT($PIECE(^HBHC(631.9,1,1,0),"^",4)=1:$ORDER(^HBHC(631.9,1,1,"B","")),1:"")
- +12 IF HBHCPARN]""
- SET HBHCPARN=$PIECE(^DG(40.8,HBHCPARN,0),"^")
- +13 SET DR="91//^S X=HBHCPARN"
- +14 SET DIE="^HBHC(631,"
- SET DA=HBHCDFN
- +15 LOCK +^HBHC(631,HBHCDFN):0
- IF $TEST
- DO ^DIE
- LOCK -^HBHC(631,HBHCDFN)
- +16 MERGE Y=HBHCSAVY
- +17 ;end of HBH*1.0*32
- End DoDot:1
- CONT ;end of MFH logic - continue with prompts, etc.
- +1 ;Parent site is required if not a MFH patient.
- +2 ;Parent site is not required for MFH patients since the MFH's parent site
- +3 ;is retrieved for AITC transmissions.
- +4 NEW HBHCQUIT
- +5 SET HBHCQUIT=1
- +6 ;Is parent site defined - if yes, may continue with prompts.
- +7 IF $PIECE($GET(^HBHC(631,HBHCDFN,5)),"^")]""
- SET HBHCQUIT=0
- +8 ;If no parent site and this is an MFH site, the patient needs to be defined
- +9 ;as an MFH patient if there is no parent site in ^HBHC(631,HBHCDFN,5).
- +10 IF HBHCQUIT
- IF $DATA(HBHCMFHS)
- IF $PIECE($GET(^HBHC(631,HBHCDFN,3)),"^")="Y"
- SET HBHCQUIT=0
- +11 if HBHCQUIT
- QUIT
- +12 DO DEMO
- +13 KILL DIE
- SET DIE="^HBHC(631,"
- SET DA=HBHCDFN
- SET DIE("NO^")="OUTOK"
- +14 ;added M code for Dx validation based on admission date
- +15 ;added M code for Dx lookup instead of field 18
- +16 SET DR="K HBHCQ;17;2:5;D BIRTHYR^HBHCUTL1;7;D SEXRACE^HBHCUTL1;10:13;14;D ACTION^HBHCUTL;15;16"
- +17 LOCK +^HBHC(631,HBHCDFN):0
- IF $TEST
- DO ^DIE
- +18 IF $DATA(Y)>0
- GOTO PROMPT
- +19 ; For ICD-9 lookups, set key variables used by special lookup routine
- +20 SET ICDVDT=$PIECE(^HBHC(631,DA,0),U,18)
- +21 SET ICDSYS=+$$SINFO^ICDEX("DIAG",ICDVDT)
- +22 IF ICDSYS=1
- SET ICDFMT=1
- +23 IF '$DATA(HBHCMFHS)
- Begin DoDot:1
- +24 SET DR=$SELECT(ICDSYS=1:"I $D(HBHCQ) K HBHCQ S Y=37;18;68;19:36;37:38;67",1:"I $D(HBHCQ) K HBHCQ S Y=37;D ADMDX^HBHCLKU1;68;19:36;37:38;67")
- End DoDot:1
- +25 IF $DATA(HBHCMFHS)
- Begin DoDot:1
- +26 SET DR=$SELECT(ICDSYS=1:"I $D(HBHCQ) K HBHCQ S Y=37;18;68;19:36;37:38;67",1:"I $D(HBHCQ) K HBHCQ S Y=37;D ADMDX^HBHCLKU1;68;19:36;37:38;67")
- End DoDot:1
- +27 DO ^DIE
- +28 LOCK -^HBHC(631,HBHCDFN)
- KILL ICDVDT,ICDSYS,ICDFMT
- GOTO PROMPT
- +29 WRITE $CHAR(7),!!,"Another user is editing this entry.",!!
- GOTO PROMPT
- EXIT ; Exit module
- +1 KILL DA,DIC,DIE,DIK,DR,HBHCAFLG,HBHCBXRF,HBHCCNTY,HBHCDFN,HBHCDPT,HBHCDPT0,HBHCEL,HBHCELGE,HBHCFLG,HBHCFORM,HBHCI,HBHCIEN,HBHCINFO,HBHCJ,HBHCMARE,HBHCMFHS,HBHCMS,HBHCNHSP,HBHCNOD0,HBHCPRCT,HBHCPS,HBHCPSRV,HBHCQ,HBHCRFLG,HBHCST
- +2 KILL HBHCXMT3,HBHCWRD1,HBHCWRD2,HBHCWRD3,HBHCY0,HBHCZIP,VAEL,X,Y
- +3 QUIT
- CHECK ; Check previous episode(s) of care for 'Reject' in Admit/Reject Action or Discharge Date to ensure completed episode of care before allowing another episode of care to be created
- +1 if ($PIECE(^HBHC(631,HBHCBXRF,0),U,15)=2)!($PIECE(^HBHC(631,HBHCBXRF,0),U,40)]"")
- QUIT
- +2 WRITE $CHAR(7),!!,"Patient must be discharged from last episode of care before new episode",!,"can be entered. Current episode not created.",!
- HANG 3
- +3 KILL DIK
- SET DIK="^HBHC(631,"
- SET DA=HBHCDFN
- DO ^DIK
- +4 SET HBHCFLG=1
- +5 QUIT
- DEMO ; Obtain patient demographic info
- +1 SET (HBHCST,HBHCCNTY,HBHCZIP,HBHCEL,HBHCELGE,HBHCPS,HBHCPSRV,HBHCMS,HBHCMARE)=""
- +2 IF $DATA(^DPT(HBHCDPT,.11))
- SET HBHCINFO=^DPT(HBHCDPT,.11)
- SET HBHCCNTY=$PIECE(HBHCINFO,U,7)
- SET HBHCZIP=$PIECE(HBHCINFO,U,12)
- SET HBHCST=$PIECE(HBHCINFO,U,5)
- +3 ;p35
- SET HBHCIEN=""
- if HBHCST
- SET HBHCIEN=$ORDER(^HBHC(631.8,"B",HBHCST,HBHCIEN))
- SET HBHCST=$SELECT($GET(HBHCIEN):HBHCIEN,1:"")
- +4 IF $DATA(^DPT(HBHCDPT,.36))
- SET DFN=HBHCDPT
- DO ELIG^VADPT
- SET HBHCEL=+VAEL(1)
- SET HBHCELGE=$SELECT(HBHCEL=1:"01",HBHCEL=2:"02",HBHCEL=16:"02",HBHCEL=11:"03",HBHCEL=4:"04",1:"05")
- KILL DFN
- +5 IF $DATA(^DPT(HBHCDPT,.32))
- SET HBHCINFO=^DPT(HBHCDPT,.32)
- SET HBHCPS=$PIECE(HBHCINFO,U,3)
- SET HBHCPSRV=$SELECT(((HBHCPS>0)&(HBHCPS<9)):HBHCPS,HBHCPS=9:10,HBHCPS=121:11,1:"")
- +6 SET HBHCINFO=^DPT(HBHCDPT,0)
- SET HBHCMS=$PIECE(HBHCINFO,U,5)
- SET HBHCMARE=$SELECT(HBHCMS=1:4,HBHCMS=2:1,HBHCMS=4:2,HBHCMS=5:3,HBHCMS=6:5,1:"")
- +7 IF HBHCST]""
- if ($PIECE(HBHCNOD0,U,3)="")&($DATA(^HBHC(631.8,HBHCST,0)))
- SET $PIECE(^HBHC(631,HBHCDFN,0),U,3)=HBHCST
- IF (HBHCCNTY]"")&($PIECE(HBHCNOD0,U,4)="")
- if $DATA(^HBHC(631.8,HBHCST,0))
- SET $PIECE(^HBHC(631,HBHCDFN,0),U,4)=HBHCCNTY
- +8 if (HBHCZIP]"")&(($PIECE(HBHCNOD0,U,5)="")!($PIECE(HBHCNOD0,U,5)'?9N))
- SET $PIECE(^HBHC(631,HBHCDFN,0),U,5)=HBHCZIP
- +9 if (HBHCELGE]"")&($PIECE(HBHCNOD0,U,6)="")
- SET $PIECE(^HBHC(631,HBHCDFN,0),U,6)=HBHCELGE
- +10 if (HBHCPSRV]"")&($PIECE(HBHCNOD0,U,8)="")
- SET $PIECE(^HBHC(631,HBHCDFN,0),U,8)=HBHCPSRV
- +11 if (HBHCMARE]"")&($PIECE(HBHCNOD0,U,11)="")
- SET $PIECE(^HBHC(631,HBHCDFN,0),U,11)=HBHCMARE
- +12 QUIT
