IB20P598 ;ALB/MJF - UPDATE MCCR UTILITY /SPECIALTY ;9/22/17
;;2.0;INTEGRATED BILLING;**598**;21-MAR-94;Build 28
;;Per VA Directive 6402, this routine should not be modified.
Q
MAIN ;order of operators
N U S U="^"
D CREATE,POINT
Q
;
CREATE ;Adds/fills records from RECORDS label to 399.1 file
N DLAYGO,DIC,DIE,DA,DD,DO,DR,X,Y,IBCOUNT,IBREC,IBNAME,IBCODE,IBABBRE,IBBED,IBIEN
D MES^XPDUTL("Adding new records to 399.1..")
F IBCOUNT=1:1 S IBREC=$P($T(RECORDS+IBCOUNT),";;",2) Q:IBREC="" D
.;Breaking the record into vars
.S IBNAME=$P(IBREC,U,1),IBCODE=$P(IBREC,U,2),IBABBRE=$P(IBREC,U,3),IBBED=$P(IBREC,U,4)
.;check to see if the record exists before adding
.I IBNAME="" Q
.S IBIEN=$O(^DGCR(399.1,"B",IBNAME,""))
.I IBNAME=$$GET1^DIQ(399.1,IBIEN,.01) D MES^XPDUTL("It appears this record "_IBNAME_" already exists.") Q ;Quit if this record has already been created
.;Add the record to 399.1
.K DD,DO S DLAYGO=399.1,DIC="^DGCR(399.1,",DIC(0)="L",X=IBNAME D FILE^DICN K DIC,DLAYGO I Y<1 K X,Y Q
.;Stuff the fields 02 code, 03 abbre, 12 bed
.S DA=+Y,DIE="^DGCR(399.1,",DR=".02///"_IBCODE_";.03///"_IBABBRE_";.12///"_IBBED D ^DIE K DIE,DA,DR,X,Y
.D MES^XPDUTL("Record "_IBNAME_" updated")
Q
;
POINT ;Adjust pointers in relevant specialty records
N DA,DIE,DR,X,Y,IBREC,IBCOUNT,IBNAME,IBIEN
D MES^XPDUTL("Updating NH HOSPICE and HOSPICE FOR ACUTE CARE pointers..")
;Getting the relevant specialty records
F IBCOUNT=1:1 S IBREC=$P($T(RECORDS+IBCOUNT),";;",2) Q:IBREC="" D
.;Piece out the name
.S IBNAME=$P(IBREC,U,1)
.I IBNAME="" Q
.;Get the IEN
.S IBIEN=$O(^DIC(42.4,"B",IBNAME,"")) I IBIEN="" Q
.;Check the IEN for validation
.I IBNAME'=$$GET1^DIQ(42.4,IBIEN,.01) D MES^XPDUTL("Record "_IBNAME_" couldn't be verified") Q ; quit if this record cannot be verified
.;Set the specialty record's pointers to the new MCCR fields
.S DA=IBIEN,DIE="^DIC(42.4,",DR="5///"_IBNAME D ^DIE
.K DIE,DA,DR,X,Y
.D MES^XPDUTL(IBNAME_" pointer updated")
Q
;
RECORDS ;records to be added name, code, abbreviation, bed
;;NH HOSPICE^10^NH HOSPICE^YES
;;HOSPICE FOR ACUTE CARE^1^HOSPICE GEN MED^YES
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P598 2194 printed Dec 13, 2024@02:03:59 Page 2
IB20P598 ;ALB/MJF - UPDATE MCCR UTILITY /SPECIALTY ;9/22/17
+1 ;;2.0;INTEGRATED BILLING;**598**;21-MAR-94;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
MAIN ;order of operators
+1 NEW U
SET U="^"
+2 DO CREATE
DO POINT
+3 QUIT
+4 ;
CREATE ;Adds/fills records from RECORDS label to 399.1 file
+1 NEW DLAYGO,DIC,DIE,DA,DD,DO,DR,X,Y,IBCOUNT,IBREC,IBNAME,IBCODE,IBABBRE,IBBED,IBIEN
+2 DO MES^XPDUTL("Adding new records to 399.1..")
+3 FOR IBCOUNT=1:1
SET IBREC=$PIECE($TEXT(RECORDS+IBCOUNT),";;",2)
if IBREC=""
QUIT
Begin DoDot:1
+4 ;Breaking the record into vars
+5 SET IBNAME=$PIECE(IBREC,U,1)
SET IBCODE=$PIECE(IBREC,U,2)
SET IBABBRE=$PIECE(IBREC,U,3)
SET IBBED=$PIECE(IBREC,U,4)
+6 ;check to see if the record exists before adding
+7 IF IBNAME=""
QUIT
+8 SET IBIEN=$ORDER(^DGCR(399.1,"B",IBNAME,""))
+9 ;Quit if this record has already been created
IF IBNAME=$$GET1^DIQ(399.1,IBIEN,.01)
DO MES^XPDUTL("It appears this record "_IBNAME_" already exists.")
QUIT
+10 ;Add the record to 399.1
+11 KILL DD,DO
SET DLAYGO=399.1
SET DIC="^DGCR(399.1,"
SET DIC(0)="L"
SET X=IBNAME
DO FILE^DICN
KILL DIC,DLAYGO
IF Y<1
KILL X,Y
QUIT
+12 ;Stuff the fields 02 code, 03 abbre, 12 bed
+13 SET DA=+Y
SET DIE="^DGCR(399.1,"
SET DR=".02///"_IBCODE_";.03///"_IBABBRE_";.12///"_IBBED
DO ^DIE
KILL DIE,DA,DR,X,Y
+14 DO MES^XPDUTL("Record "_IBNAME_" updated")
End DoDot:1
+15 QUIT
+16 ;
POINT ;Adjust pointers in relevant specialty records
+1 NEW DA,DIE,DR,X,Y,IBREC,IBCOUNT,IBNAME,IBIEN
+2 DO MES^XPDUTL("Updating NH HOSPICE and HOSPICE FOR ACUTE CARE pointers..")
+3 ;Getting the relevant specialty records
+4 FOR IBCOUNT=1:1
SET IBREC=$PIECE($TEXT(RECORDS+IBCOUNT),";;",2)
if IBREC=""
QUIT
Begin DoDot:1
+5 ;Piece out the name
+6 SET IBNAME=$PIECE(IBREC,U,1)
+7 IF IBNAME=""
QUIT
+8 ;Get the IEN
+9 SET IBIEN=$ORDER(^DIC(42.4,"B",IBNAME,""))
IF IBIEN=""
QUIT
+10 ;Check the IEN for validation
+11 ; quit if this record cannot be verified
IF IBNAME'=$$GET1^DIQ(42.4,IBIEN,.01)
DO MES^XPDUTL("Record "_IBNAME_" couldn't be verified")
QUIT
+12 ;Set the specialty record's pointers to the new MCCR fields
+13 SET DA=IBIEN
SET DIE="^DIC(42.4,"
SET DR="5///"_IBNAME
DO ^DIE
+14 KILL DIE,DA,DR,X,Y
+15 DO MES^XPDUTL(IBNAME_" pointer updated")
End DoDot:1
+16 QUIT
+17 ;
RECORDS ;records to be added name, code, abbreviation, bed
+1 ;;NH HOSPICE^10^NH HOSPICE^YES
+2 ;;HOSPICE FOR ACUTE CARE^1^HOSPICE GEN MED^YES
+3 ;
