IBTRH7 ;ALB/JWS - HCSR Manually Create 278 Request ;15-MAY-2015
;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
;;Per VA Directive 6402, this routine should not be modified.
;;
Q
EN ;EP
; Main entry point for IBT HCSR MANUAL 278 ADD protocol
; Input: None
K ^TMP($J,"IBTRH7")
N PATIEN,HCSR,SDATE1,SDATE2,FRDATE
D FULL^VALM1
S VALMBCK="R"
S PATIEN=$$ASKPAT()
I PATIEN<0 Q
S HCSR=$G(^IBE(350.9,1,62)) ; HCSR Site Parameters
;
D DT^DILF("E","T-"_$P(HCSR,"^",3),.SDATE1)
D DT^DILF("E","T+"_$P(HCSR,"^",13),.SDATE2)
S FRDATE=$$ASKDATE("Date",SDATE1(0),SDATE2(0)) Q:FRDATE=""
;
; First find all of the scheduled appointments that match the filter criteria
N ADATE,AINS,AINSIX,CLINIC,SDCOUNT,SFILT,NODE0
K ^TMP($J,"SDAMA301")
D SETFILTS^IBTRHDE(HCSR,.SFILT) ; Set Appointment filters
S SFILT(1)=$TR(FRDATE,"^",";")
S SFILT(4)=PATIEN
S SDCOUNT=$$SDAPI^SDAMA301(.SFILT) ; Find the appointments, DBIA4433
;Q:SDCOUNT<1 ; No appointments returned
;
; Check the active insurance for every found filter against the HCSR Site
; parameter list of insurance companies to exclude
; loop through Appointment Date/time
S ADATE=$P(FRDATE,"^")-1
F S ADATE=$O(^TMP($J,"SDAMA301",PATIEN,ADATE)) Q:ADATE="" Q:$P(ADATE,".")>$P(FRDATE,"^",2) D
. D CKAFINS^IBTRHDE(HCSR,PATIEN,$P(ADATE,"."),65,.AINS,1) ; Check for valid Insurance(s)
. S AINSIX="" F S AINSIX=$O(AINS(AINSIX)) Q:AINSIX="" D
.. S CLINIC=$P($P(^TMP($J,"SDAMA301",PATIEN,ADATE),U,2),";",1)
.. ; check for clinic inclusion
.. ;I $O(^IBE(350.9,1,63,"B",CLINIC,""))="" Q
.. ;I '$$CHKLIST^IBTRHDE(63,$O(^IBE(350.9,1,63,"B",CLINIC,"")),$P(AINS(AINSIX),U)) Q
.. ; File the event
.. ; Appointment Date/Time is the 'IEN' of the appointment
.. S NODE0="Appointment^"_$$NOW^XLFDT()_U_PATIEN_U_AINSIX_"^O^^"_CLINIC_U_ADATE_U_ADATE_"^"_$P(AINS(AINSIX),"^")
.. ;save off NODE0 by entry in list
.. D SAVE(NODE0)
.. Q
. Q
; Finds all admissions that match the filter criteria. Each found
; admission is then further filtered using the HCSR Site Parameters.
; Admissions that match the filter criteria are then filed into the HCS
; Review Transmission file (356.22)
; Input: HSCR - HCSR Site Parameter filters
; Output: Filtered admissions filed into 356.22
N DA,DATEC,DATEE,DATES,DFN,IBWARD,XX,YY
K AINS,AINSIX,NODE0
;D GETDAYS2^IBTRHDE(HCSR,.DATES,.DATEE)
;D DT^DILF("","T-"_(DATES-1),.DATEC) ; Past Admission Search date
;D DT^DILF("","T+"_DATEE,.DATEE) ; Future Admission Search date
;
; First check past/present admissions
S DATEC=$P(FRDATE,"^")-1
F S DATEC=$O(^DGPM("AMV1",DATEC)) Q:(DATEC="")!($P(DATEC,".")>$P(FRDATE,"^",2)) D ; DBIA419
. S DA="" F S DA=$O(^DGPM("AMV1",DATEC,PATIEN,DA)) Q:DA="" D
.. S IBWARD=$$GET1^DIQ(405,DA_",",.06,"I")
.. D CKAFINS^IBTRHDE(HCSR,PATIEN,$P(DATEC,"."),66,.AINS,1) ; Check for valid Insurance(s)
.. S AINSIX="" F S AINSIX=$O(AINS(AINSIX)) Q:AINSIX="" D
... ; check for ward exclusion
... ;I '$$CHKLIST^IBTRHDE(64,$O(^IBE(350.9,1,64,"B",IBWARD,"")),$P(AINS(AINSIX),U)) Q
... ; File the event
... S XX=DATEC
... S YY=$$GET1^DIQ(405,DA_",",.17,"I") ; Is there a Discharge
... I YY'="" D ; Get External Discharge Date
.... S YY=$$GET1^DIQ(405,DA_",",.01,"I") ; Discharge Date/Time
.... S XX=XX_"-"_YY
.... Q
... S NODE0="Admission^"_$$NOW^XLFDT()_U_PATIEN_U_AINSIX_"^I^"_IBWARD_"^^"_XX_U_$P(DATEC,".",1)_"^"_$P(AINS(AINSIX),"^")
... D SAVE(NODE0)
... Q
.. Q
. Q
;
; Next check future admissions
;D DT^DILF("","T-"_(DATES-1),.DATEC) ; Past Admission Search date
S DATEC=$P(FRDATE,"^")-1
F S DATEC=$O(^DGS(41.1,"C",DATEC)) Q:(DATEC="")!($P(DATEC,".")>$P(FRDATE,"^",2)) D ; DBIA429
. S DA="" F S DA=$O(^DGS(41.1,"C",DATEC,DA)) Q:DA="" D
.. Q:$P($G(^DGS(41.1,DA,0)),U,13)'="" ; Future Admission was cancelled
.. S IBWARD=$$GET1^DIQ(41.1,DA_",",8,"I")
.. S DFN=$$GET1^DIQ(41.1,DA_",",.01,"I") ; Patient DFN
.. I DFN'=PATIEN Q ;filter based on what patient user selected
.. D CKAFINS^IBTRHDE(HCSR,DFN,$P(DATEC,"."),66,.AINS,1) ; Check for valid Insurance(s)
.. S AINSIX="" F S AINSIX=$O(AINS(AINSIX)) Q:AINSIX="" D
... ; check for ward exclusion
... ;I '$$CHKLIST^IBTRHDE(64,$O(^IBE(350.9,1,64,"B",IBWARD)),$P(AINS(AINSIX),U)) Q
... ; File the event
... S NODE0="Admission^"_$$NOW^XLFDT()_U_DFN_U_AINSIX_"^I^"_IBWARD_"^^"_DATEC_U_$P(DATEC,".",1)_"^"_$P(AINS(AINSIX),"^")
... D SAVE(NODE0)
... Q
.. Q
. Q
I '$O(^TMP($J,"IBTRH7","")) W !,"No open appointments or admissions found for that patient",! D PAUSE^VALM1 Q
;
; display list of options and then add entry to 356.22
N CNT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,TMP,X
S CNT=+$G(^TMP($J,"IBTRH7"))
S X="" F S X=$O(^TMP($J,"IBTRH7",X)) Q:X="" D
. N X1,X2
. S X1=^TMP($J,"IBTRH7",X)
. S Y=$P(X1,"^",8) X ^DD("DD")
. S X2=$E(X_" ",1,4)_$E($P(X1,"^"),1,3)_" "_Y_" "
. I $P(X1,"^",7) S X2=X2_$$GET1^DIQ(44,$P(X1,"^",7),.01)
. I $P(X1,"^",6) S X2=X2_$$GET1^DIQ(42,$P(X1,"^",6),.01)
. S X2=X2_$J(" ",40-$L(X2))
. S X2=X2_" "_$E($$GET1^DIQ(2.312,$P(X1,"^",4)_","_$P(X1,"^",3)_",",.2),1,3)_": "_$E($$GET1^DIQ(36,$P(X1,"^",10)_",",.01),1,26)
. ;S LINE=$G(LINE)+1
. S TMP("DIMSG",X)=X2
D MSG^DIALOG("WM",,,,"TMP")
S DIR(0)="NA^1:"_CNT_":0"
S DIR("A")="Select a scheduled Admission or Appointment for the selected Patient: "
S DIR("?",1)="Choose an admission or appointment."
S DIR("?")="Valid responses are 1 thru "_CNT_" or ^ to exit."
D ^DIR
I ($G(DTOUT))!($G(DUOUT))!($G(DIRUT))!($G(DIROUT)) Q
I +$G(Y)<1 Q
; add entry to 356.22 file
S NODE0=$P(^TMP($J,"IBTRH7",Y),"^",2,9)
D SETEVENT^IBTRHDE(NODE0)
;D SORT^IBTRH1(1)
D INIT^IBTRH1
D HDR^IBTRH1
Q
;
ASKPAT() ; Get the Patient Name
; Init vars
N DIC,DTOUT,DUOUT,X,Y
; Patient lookup
W !
S DIC(0)="AEQM" ;,DIC("S")="I $D(^IBT(356.22,""D"",Y))"
S DIC("A")=$$FO^IBCNEUT1("Select PATIENT NAME: ",21,"R")
S DIC="^DPT("
D ^DIC
Q +Y
;
ASKDATE(PROMPT,DEFAULT1,DEFAULT2) ; get the from and thru dates
N %DT,X,Y,DT1,DT2,IB1,IB2
S DT1="",IB1="Start Date: ",IB2="End Date: "
I $G(PROMPT)'="" S IB1="Start with "_PROMPT_": ",IB2="Go to "_PROMPT_": "
FM1 ;
S %DT="AEX",%DT("A")=IB1,%DT("B")=DEFAULT1
D ^%DT K %DT I Y<0!($P(Y,".",1)'?7N) G FM1E:(Y<0&(X="")),FMDQ
S (%DT(0),DT2)=$P(Y,".",1) I DT2'>SDATE2 S %DT("B")=DEFAULT2
FM2 ;
S %DT="AEX",%DT("A")=IB2 D ^%DT K %DT I Y<0!($P(Y,".",1)'?7N) G FM2E:(Y<0&(X="")),FMDQ
S DT1=DT2_"^"_$P(Y,".",1)
FMDQ ;
Q DT1
FM1E ;
W !,"A date must be entered." G FM1
FM2E ;
W !,"A date must be entered." G FM2
Q
Q X
;
SAVE(NODE0) ; save entry in temporary ^TMP($J) global for list display
N VAL,ERR,XCT
S VAL(1)=$P(NODE0,"^",3)
S VAL(2)=$P(NODE0,"^",5)
S VAL(3)=$P(NODE0,"^",4)
S VAL(4)=$P(NODE0,"^",9)
I $$FIND1^DIC(356.22,,"Q",.VAL,"E","","ERR") Q
I $D(ERR) Q
S XCT=$G(^TMP($J,"IBTRH7")),XCT=XCT+1,^TMP($J,"IBTRH7")=XCT,^("IBTRH7",XCT)=NODE0
Q
;
FILE ; save selected entry into 356.22 file
D SETEVENT^IBTRHDE(NODE0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRH7 7221 printed Dec 13, 2024@02:28:19 Page 2
IBTRH7 ;ALB/JWS - HCSR Manually Create 278 Request ;15-MAY-2015
+1 ;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;
+4 QUIT
EN ;EP
+1 ; Main entry point for IBT HCSR MANUAL 278 ADD protocol
+2 ; Input: None
+3 KILL ^TMP($JOB,"IBTRH7")
+4 NEW PATIEN,HCSR,SDATE1,SDATE2,FRDATE
+5 DO FULL^VALM1
+6 SET VALMBCK="R"
+7 SET PATIEN=$$ASKPAT()
+8 IF PATIEN<0
QUIT
+9 ; HCSR Site Parameters
SET HCSR=$GET(^IBE(350.9,1,62))
+10 ;
+11 DO DT^DILF("E","T-"_$PIECE(HCSR,"^",3),.SDATE1)
+12 DO DT^DILF("E","T+"_$PIECE(HCSR,"^",13),.SDATE2)
+13 SET FRDATE=$$ASKDATE("Date",SDATE1(0),SDATE2(0))
if FRDATE=""
QUIT
+14 ;
+15 ; First find all of the scheduled appointments that match the filter criteria
+16 NEW ADATE,AINS,AINSIX,CLINIC,SDCOUNT,SFILT,NODE0
+17 KILL ^TMP($JOB,"SDAMA301")
+18 ; Set Appointment filters
DO SETFILTS^IBTRHDE(HCSR,.SFILT)
+19 SET SFILT(1)=$TRANSLATE(FRDATE,"^",";")
+20 SET SFILT(4)=PATIEN
+21 ; Find the appointments, DBIA4433
SET SDCOUNT=$$SDAPI^SDAMA301(.SFILT)
+22 ;Q:SDCOUNT<1 ; No appointments returned
+23 ;
+24 ; Check the active insurance for every found filter against the HCSR Site
+25 ; parameter list of insurance companies to exclude
+26 ; loop through Appointment Date/time
+27 SET ADATE=$PIECE(FRDATE,"^")-1
+28 FOR
SET ADATE=$ORDER(^TMP($JOB,"SDAMA301",PATIEN,ADATE))
if ADATE=""
QUIT
if $PIECE(ADATE,".")>$PIECE(FRDATE,"^",2)
QUIT
Begin DoDot:1
+29 ; Check for valid Insurance(s)
DO CKAFINS^IBTRHDE(HCSR,PATIEN,$PIECE(ADATE,"."),65,.AINS,1)
+30 SET AINSIX=""
FOR
SET AINSIX=$ORDER(AINS(AINSIX))
if AINSIX=""
QUIT
Begin DoDot:2
+31 SET CLINIC=$PIECE($PIECE(^TMP($JOB,"SDAMA301",PATIEN,ADATE),U,2),";",1)
+32 ; check for clinic inclusion
+33 ;I $O(^IBE(350.9,1,63,"B",CLINIC,""))="" Q
+34 ;I '$$CHKLIST^IBTRHDE(63,$O(^IBE(350.9,1,63,"B",CLINIC,"")),$P(AINS(AINSIX),U)) Q
+35 ; File the event
+36 ; Appointment Date/Time is the 'IEN' of the appointment
+37 SET NODE0="Appointment^"_$$NOW^XLFDT()_U_PATIEN_U_AINSIX_"^O^^"_CLINIC_U_ADATE_U_ADATE_"^"_$PIECE(AINS(AINSIX),"^")
+38 ;save off NODE0 by entry in list
+39 DO SAVE(NODE0)
+40 QUIT
End DoDot:2
+41 QUIT
End DoDot:1
+42 ; Finds all admissions that match the filter criteria. Each found
+43 ; admission is then further filtered using the HCSR Site Parameters.
+44 ; Admissions that match the filter criteria are then filed into the HCS
+45 ; Review Transmission file (356.22)
+46 ; Input: HSCR - HCSR Site Parameter filters
+47 ; Output: Filtered admissions filed into 356.22
+48 NEW DA,DATEC,DATEE,DATES,DFN,IBWARD,XX,YY
+49 KILL AINS,AINSIX,NODE0
+50 ;D GETDAYS2^IBTRHDE(HCSR,.DATES,.DATEE)
+51 ;D DT^DILF("","T-"_(DATES-1),.DATEC) ; Past Admission Search date
+52 ;D DT^DILF("","T+"_DATEE,.DATEE) ; Future Admission Search date
+53 ;
+54 ; First check past/present admissions
+55 SET DATEC=$PIECE(FRDATE,"^")-1
+56 ; DBIA419
FOR
SET DATEC=$ORDER(^DGPM("AMV1",DATEC))
if (DATEC="")!($PIECE(DATEC,".")>$PIECE(FRDATE,"^",2))
QUIT
Begin DoDot:1
+57 SET DA=""
FOR
SET DA=$ORDER(^DGPM("AMV1",DATEC,PATIEN,DA))
if DA=""
QUIT
Begin DoDot:2
+58 SET IBWARD=$$GET1^DIQ(405,DA_",",.06,"I")
+59 ; Check for valid Insurance(s)
DO CKAFINS^IBTRHDE(HCSR,PATIEN,$PIECE(DATEC,"."),66,.AINS,1)
+60 SET AINSIX=""
FOR
SET AINSIX=$ORDER(AINS(AINSIX))
if AINSIX=""
QUIT
Begin DoDot:3
+61 ; check for ward exclusion
+62 ;I '$$CHKLIST^IBTRHDE(64,$O(^IBE(350.9,1,64,"B",IBWARD,"")),$P(AINS(AINSIX),U)) Q
+63 ; File the event
+64 SET XX=DATEC
+65 ; Is there a Discharge
SET YY=$$GET1^DIQ(405,DA_",",.17,"I")
+66 ; Get External Discharge Date
IF YY'=""
Begin DoDot:4
+67 ; Discharge Date/Time
SET YY=$$GET1^DIQ(405,DA_",",.01,"I")
+68 SET XX=XX_"-"_YY
+69 QUIT
End DoDot:4
+70 SET NODE0="Admission^"_$$NOW^XLFDT()_U_PATIEN_U_AINSIX_"^I^"_IBWARD_"^^"_XX_U_$PIECE(DATEC,".",1)_"^"_$PIECE(AINS(AINSIX),"^")
+71 DO SAVE(NODE0)
+72 QUIT
End DoDot:3
+73 QUIT
End DoDot:2
+74 QUIT
End DoDot:1
+75 ;
+76 ; Next check future admissions
+77 ;D DT^DILF("","T-"_(DATES-1),.DATEC) ; Past Admission Search date
+78 SET DATEC=$PIECE(FRDATE,"^")-1
+79 ; DBIA429
FOR
SET DATEC=$ORDER(^DGS(41.1,"C",DATEC))
if (DATEC="")!($PIECE(DATEC,".")>$PIECE(FRDATE,"^",2))
QUIT
Begin DoDot:1
+80 SET DA=""
FOR
SET DA=$ORDER(^DGS(41.1,"C",DATEC,DA))
if DA=""
QUIT
Begin DoDot:2
+81 ; Future Admission was cancelled
if $PIECE($GET(^DGS(41.1,DA,0)),U,13)'=""
QUIT
+82 SET IBWARD=$$GET1^DIQ(41.1,DA_",",8,"I")
+83 ; Patient DFN
SET DFN=$$GET1^DIQ(41.1,DA_",",.01,"I")
+84 ;filter based on what patient user selected
IF DFN'=PATIEN
QUIT
+85 ; Check for valid Insurance(s)
DO CKAFINS^IBTRHDE(HCSR,DFN,$PIECE(DATEC,"."),66,.AINS,1)
+86 SET AINSIX=""
FOR
SET AINSIX=$ORDER(AINS(AINSIX))
if AINSIX=""
QUIT
Begin DoDot:3
+87 ; check for ward exclusion
+88 ;I '$$CHKLIST^IBTRHDE(64,$O(^IBE(350.9,1,64,"B",IBWARD)),$P(AINS(AINSIX),U)) Q
+89 ; File the event
+90 SET NODE0="Admission^"_$$NOW^XLFDT()_U_DFN_U_AINSIX_"^I^"_IBWARD_"^^"_DATEC_U_$PIECE(DATEC,".",1)_"^"_$PIECE(AINS(AINSIX),"^")
+91 DO SAVE(NODE0)
+92 QUIT
End DoDot:3
+93 QUIT
End DoDot:2
+94 QUIT
End DoDot:1
+95 IF '$ORDER(^TMP($JOB,"IBTRH7",""))
WRITE !,"No open appointments or admissions found for that patient",!
DO PAUSE^VALM1
QUIT
+96 ;
+97 ; display list of options and then add entry to 356.22
+98 NEW CNT,DIR,DIROUT,DIRUT,DTOUT,DUOUT,TMP,X
+99 SET CNT=+$GET(^TMP($JOB,"IBTRH7"))
+100 SET X=""
FOR
SET X=$ORDER(^TMP($JOB,"IBTRH7",X))
if X=""
QUIT
Begin DoDot:1
+101 NEW X1,X2
+102 SET X1=^TMP($JOB,"IBTRH7",X)
+103 SET Y=$PIECE(X1,"^",8)
XECUTE ^DD("DD")
+104 SET X2=$EXTRACT(X_" ",1,4)_$EXTRACT($PIECE(X1,"^"),1,3)_" "_Y_" "
+105 IF $PIECE(X1,"^",7)
SET X2=X2_$$GET1^DIQ(44,$PIECE(X1,"^",7),.01)
+106 IF $PIECE(X1,"^",6)
SET X2=X2_$$GET1^DIQ(42,$PIECE(X1,"^",6),.01)
+107 SET X2=X2_$JUSTIFY(" ",40-$LENGTH(X2))
+108 SET X2=X2_" "_$EXTRACT($$GET1^DIQ(2.312,$PIECE(X1,"^",4)_","_$PIECE(X1,"^",3)_",",.2),1,3)_": "_$EXTRACT($$GET1^DIQ(36,$PIECE(X1,"^",10)_",",.01),1,26)
+109 ;S LINE=$G(LINE)+1
+110 SET TMP("DIMSG",X)=X2
End DoDot:1
+111 DO MSG^DIALOG("WM",,,,"TMP")
+112 SET DIR(0)="NA^1:"_CNT_":0"
+113 SET DIR("A")="Select a scheduled Admission or Appointment for the selected Patient: "
+114 SET DIR("?",1)="Choose an admission or appointment."
+115 SET DIR("?")="Valid responses are 1 thru "_CNT_" or ^ to exit."
+116 DO ^DIR
+117 IF ($GET(DTOUT))!($GET(DUOUT))!($GET(DIRUT))!($GET(DIROUT))
QUIT
+118 IF +$GET(Y)<1
QUIT
+119 ; add entry to 356.22 file
+120 SET NODE0=$PIECE(^TMP($JOB,"IBTRH7",Y),"^",2,9)
+121 DO SETEVENT^IBTRHDE(NODE0)
+122 ;D SORT^IBTRH1(1)
+123 DO INIT^IBTRH1
+124 DO HDR^IBTRH1
+125 QUIT
+126 ;
ASKPAT() ; Get the Patient Name
+1 ; Init vars
+2 NEW DIC,DTOUT,DUOUT,X,Y
+3 ; Patient lookup
+4 WRITE !
+5 ;,DIC("S")="I $D(^IBT(356.22,""D"",Y))"
SET DIC(0)="AEQM"
+6 SET DIC("A")=$$FO^IBCNEUT1("Select PATIENT NAME: ",21,"R")
+7 SET DIC="^DPT("
+8 DO ^DIC
+9 QUIT +Y
+10 ;
ASKDATE(PROMPT,DEFAULT1,DEFAULT2) ; get the from and thru dates
+1 NEW %DT,X,Y,DT1,DT2,IB1,IB2
+2 SET DT1=""
SET IB1="Start Date: "
SET IB2="End Date: "
+3 IF $GET(PROMPT)'=""
SET IB1="Start with "_PROMPT_": "
SET IB2="Go to "_PROMPT_": "
FM1 ;
+1 SET %DT="AEX"
SET %DT("A")=IB1
SET %DT("B")=DEFAULT1
+2 DO ^%DT
KILL %DT
IF Y<0!($PIECE(Y,".",1)'?7N)
if (Y<0&(X=""))
GOTO FM1E
GOTO FMDQ
+3 SET (%DT(0),DT2)=$PIECE(Y,".",1)
IF DT2'>SDATE2
SET %DT("B")=DEFAULT2
FM2 ;
+1 SET %DT="AEX"
SET %DT("A")=IB2
DO ^%DT
KILL %DT
IF Y<0!($PIECE(Y,".",1)'?7N)
if (Y<0&(X=""))
GOTO FM2E
GOTO FMDQ
+2 SET DT1=DT2_"^"_$PIECE(Y,".",1)
FMDQ ;
+1 QUIT DT1
FM1E ;
+1 WRITE !,"A date must be entered."
GOTO FM1
FM2E ;
+1 WRITE !,"A date must be entered."
GOTO FM2
+2 QUIT
+3 QUIT X
+4 ;
SAVE(NODE0) ; save entry in temporary ^TMP($J) global for list display
+1 NEW VAL,ERR,XCT
+2 SET VAL(1)=$PIECE(NODE0,"^",3)
+3 SET VAL(2)=$PIECE(NODE0,"^",5)
+4 SET VAL(3)=$PIECE(NODE0,"^",4)
+5 SET VAL(4)=$PIECE(NODE0,"^",9)
+6 IF $$FIND1^DIC(356.22,,"Q",.VAL,"E","","ERR")
QUIT
+7 IF $DATA(ERR)
QUIT
+8 SET XCT=$GET(^TMP($JOB,"IBTRH7"))
SET XCT=XCT+1
SET ^TMP($JOB,"IBTRH7")=XCT
SET ^("IBTRH7",XCT)=NODE0
+9 QUIT
+10 ;
FILE ; save selected entry into 356.22 file
+1 DO SETEVENT^IBTRHDE(NODE0)
+2 QUIT
