IBTRH3 ;ALB/VAD - IBT HCSR RESPONSE VIEW ;02-JUN-2014
;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; -- main entry point for IBT HCSR Response View
N IBPTNO,IBTRIEN,IBOK,DATA,IBTRNM,IBTRSPEC
N DFN,NODE0,IEN312,INSNODE0,VALMCNT
S IBTRNM="IBTRH3"
;
D EN^VALM("IBT HCSR RESPONSE VIEW")
I $G(IBPTNO)'=-1,'$D(IBFASTXT) K IBTNO,IBTRIEN,IBOK,DATA,IBTRN,IBTRSPEC,DFN,NODE0,IEN312,INSNODE0,VALMCNT G EN
Q
;
EN2 ;JWS;alternate entry point when IBTRIEN is selected from
; a response list view, so IBTRIEN is known
N DLINE,IBPTNO,IBTRIEN,IBOK,DATA,IBTRNM,IBTRSPEC
N DFN,NODE0,IEN312,INSNODE0,VALMCNT
S IBTRNM="IBTRH3"
S IBTRIEN=+$$SELEVENT^IBTRH5(0,"Select entry",.DLINE) ; select entry to expand
I IBTRIEN'>0 Q
D EN^VALM("IBT HCSR RESPONSE VIEW")
Q
;
EN3 ;alternate entry point when IBTRIEN is selected from
; a response list view to display response pending entry,
; so IBTRIEN is known for the current entry and we need
; to figure out the pending response.
N CURIEN,CURNODE0
S CURIEN=IBTRIEN
S CURNODE0=NODE0
;
N DLINE,IBPTNO,IBTRIEN,IBOK,DATA,IBTRNM,IBTRSPEC
N DFN,NODE0,IEN312,INSNODE0,VALMCNT
S IBTRNM="IBTRH3"
I $P(CURNODE0,U,8)'="07" D NODP Q
S IBTRIEN=$P(CURNODE0,U,14)
I IBTRIEN'>0 D NODP Q
D EN^VALM("IBT HCSR RESPONSE VIEW")
Q
;
HDR ; -- header code
N VADM,Z
S Z=""
I +$G(DFN) D DEM^VADPT S Z=$E(VADM(1),1,28),Z=Z_$J("",35-$L(Z))_$P(VADM(2),U,2)_" DOB: "_$P(VADM(3),U,2)_" AGE: "_VADM(4)
S VALMHDR(1)=Z
S VALMSG="#In-Prog"
Q
;
INIT ; -- init variables and list array
;JWS 9/9/14 - added conditions based on IBTRIEN already selected
K ^TMP(IBTRNM,$J)
;
; May need a switch or 2 to call INIT^IBTRH2 one to not display comments and
; maybe another to change the primary subscript from "IBTRH2" to something else
;
; JWS 9/9/14 - if response IEN has value, set PATIENT variable and skip forward
I +$G(IBTRIEN) S IBPTNO=$P($G(^IBT(356.22,IBTRIEN,0)),U,2) G INIT1
; Get the Patient.
S IBPTNO=$$ASKPAT() I IBPTNO=-1 S VALMQUIT="" G INITQ
I '$D(^IBT(356.22,"D",IBPTNO)) D G INIT
. W !,"No HCSR Response data for this Patient.",!
;
; Get the Appointment/Admission Date.
S IBTRIEN=$$ASKEVT(IBPTNO)
I IBTRIEN=-1 S VALMQUIT="" G INITQ
I '$G(IBTRIEN) S VALMQUIT="" G INITQ
INIT1 ;
S IBTRSPEC("IBTPATID")=IBPTNO
S IBTRSPEC("IBTEVENT")=IBTRIEN
;
S NODE0=$G(^IBT(356.22,IBTRIEN,0))
S DFN=+$P(NODE0,U,2)
S IEN312=+$P(NODE0,U,3)
S INSNODE0="" S:IEN312>0 INSNODE0=$G(^DPT(DFN,.312,IEN312,0)) ; 0-node in file 2.312
;
; Compile the data for the display.
D COMPILE(IBTRNM,.IBTRSPEC)
INITQ 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
;
ASKEVT(IBTRIEN) ; Get the Appointment/Admission
N A1,A2,MX,SEL,YY,XIEN,XREQ,XREQDATA
S YY=$$GTLIST(IBTRIEN) I YY=-1 D NODP G ASKEVTX ; If no Appts Quit.
ASKEVT1 ;
S A1="",MX=0
W !!!,"Select Appt/Adm:",!
; Loop through the list if Appointments/Admissions and display each one.
F S A1=$O(^TMP("IBTRH3E",$J,"XLISTNO",A1)) Q:A1="" S A2=$P(^(A1),"^",3) D
. S XIEN=+$G(^TMP("IBTRH3E",$J,"DILIST",2,A2))
. S XREQ=+$P($G(^IBT(356.22,XIEN,0)),"^",13),XREQDATA=$G(^IBT(356.22,XREQ,0))
. W !?5,A1,". ",$S($P(XREQDATA,"^",4)="I":"Adm: ",1:"App: ")
. W $$FMTE^XLFDT($P(^TMP("IBTRH3E",$J,"XLISTNO",A1),U,1))," "
. W $S($P(XREQDATA,"^",20)=1:"215:",1:"217:") S MX=A1
. W " ",$$FMTE^XLFDT($P($P(XREQDATA,U,15),"."))," "
. I $P($G(^IBT(356.22,XIEN,103)),"^") W $$GET1^DIQ(356.22,XIEN_",",103.01)
. E I $D(^IBT(356.22,XIEN,101)) W "AAA"
R !,"Enter Selection: ",SEL:DTIME I SEL=""!(SEL="^") S YY=-1 G ASKEVTX ; Nothing selected.
I SEL<1!(SEL>MX) W !?5,"INVALID SELECTION.",! G ASKEVT1
S YY=$P($G(^TMP("IBTRH3E",$J,"XLISTNO",SEL)),U,3)
S YY=+$G(^TMP("IBTRH3E",$J,"DILIST",2,YY))
I YY=0 S YY=-1
ASKEVTX Q YY
;
GTLIST(IBTRIEN) ; Create list of Appointments/Admission Dates.
; This will create a ^TMP global that will look similar to the following:
; ^TMP("IBTRH3E",$J,"DILIST",0)="1^*^0^"
; ^TMP("IBTRH3E",$J,"DILIST",0,"MAP")=.07
; ^TMP("IBTRH3E",$J,"DILIST",I1,J)="JUN 19, 2014@11:00"
; ^TMP("IBTRH3E",$J,"DILIST",I2,J)=IBTRNO
; ^TMP("IBTRH3E",$J,"DILIST","ID",J,.07)=IBTEVNT
; where:
; I1 = The first cross-reference index which has the external event date values to display.
; I2 = The second cross-reference index which has the pointers to the IBT(356.22,...) Record no.
; J = Is just the internal counter of events for the selected patient.
; And ^IBT(356.22,"D",IBTRIEN,IBTEVNT,IBTRNO) is the actual Cross-reference record.
;
N A,B,X,Z,Z1
S X=-1
K ^TMP("IBTRH3E",$J)
; Only want Responses for the selected Patient.
D LIST^DIC(356.22,,".07",,,,,,"I $P(^(0),U,2)=IBTRIEN,$P(^(0),U,20)=2",,"^TMP(""IBTRH3E"",$J)")
I +$P($G(^TMP("IBTRH3E",$J,"DILIST",0)),U,1) D
. S A=""
. F S A=$O(^TMP("IBTRH3E",$J,"DILIST","ID",A)) Q:A="" D
. . S B=^(A,.07) S ^TMP("IBTRH3E",$J,"XLIST",B,$G(^TMP("IBTRH3E",$J,"DILIST",1,A)))=A
. S Z=0,(A,B)=""
. F S A=$O(^TMP("IBTRH3E",$J,"XLIST",A)) Q:A="" D ; Appt/Adm
. . S B=""
. . F S B=$O(^TMP("IBTRH3E",$J,"XLIST",A,B)) Q:B="" S Z1=$G(^(B)) D ; Date Entered
. . . S Z=Z+1
. . . S ^TMP("IBTRH3E",$J,"XLISTNO",Z)=A_U_B_U_Z1
. S X=1
Q X
;
COMPILE(IBTRNM,IBTRSPEC) ; -- Compile the data
K ^TMP(IBTRNM,$J)
;
; Compile Data
D SETDATA,BLD
Q
;
SETDATA ; -- Set up the data
N SQ,SQ1,SQ2,SQ3,SQ4,X,IBTRNO
S IBTRNO=IBTRSPEC("IBTEVENT")
S DATA(0)=$G(^IBT(356.22,IBTRNO,0))
;
I $D(^IBT(356.22,IBTRNO,1)) D ; Comments Multiple.
. S SQ="" F S SQ=$O(^IBT(356.22,IBTRNO,1,SQ)) Q:SQ="" S DATA(1,SQ,0)=$G(^IBT(356.22,IBTRNO,1,SQ,0))
;
S DATA(2)=$G(^IBT(356.22,IBTRNO,2))
;
I $D(^IBT(356.22,IBTRNO,3)) D ; Patient Diagnosis Multiple.
. S SQ=0 F S SQ=$O(^IBT(356.22,IBTRNO,3,SQ)) Q:SQ="" S DATA(3,SQ,0)=$G(^IBT(356.22,IBTRNO,3,SQ,0))
;
S DATA(4)=$G(^IBT(356.22,IBTRNO,4))
S DATA(7)=$G(^IBT(356.22,IBTRNO,7))
S DATA(8)=$G(^IBT(356.22,IBTRNO,8))
S DATA(9)=$G(^IBT(356.22,IBTRNO,9))
S DATA(10)=$G(^IBT(356.22,IBTRNO,10))
;
I $D(^IBT(356.22,IBTRNO,11)) D ; Attachments Multiple.
. S SQ=0 F S SQ=$O(^IBT(356.22,IBTRNO,11,SQ)) Q:(SQ="")!('+SQ) S DATA(11,SQ,0)=$G(^IBT(356.22,IBTRNO,11,SQ,0))
;
I $D(^IBT(356.22,IBTRNO,12)) D
. N SQ1,TEXT
. S SQ=0 F S SQ=$O(^IBT(356.22,IBTRNO,12,SQ)) Q:SQ="" D
. . S TEXT=$G(^IBT(356.22,IBTRNO,12,SQ,0))
. . I $L(TEXT)>80 D Q
. . . N SAV,X1,END
. . . S END=$L(TEXT," ")
. . . F I=1:1:END S X1=$P(TEXT," ",I) D
. . . . I X1="",$G(SAV)="" Q
. . . . I X1="" S X1=" "
. . . . I $L(X1)+$L($G(SAV))<78 S:$G(SAV)'="" SAV=SAV_" " S SAV=$G(SAV)_X1 Q
. . . . S SQ1=$G(SQ1)+1,DATA(12,SQ1)=SAV,SAV=X1
. . . I $G(SAV)'="" S SQ1=$G(SQ1)+1,DATA(12,SQ1)=SAV
. . . S DATA(12,0)=SQ1
. . S SQ1=$G(SQ1)+1,DATA(12,SQ1)=TEXT
. . S DATA(12,0)=+SQ1
;
I $D(^IBT(356.22,IBTRNO,13)) D ; Patient Event Provider Multiple.
. S SQ1=0 F S SQ1=$O(^IBT(356.22,IBTRNO,13,SQ1)) Q:SQ1="" D
. . I SQ1'?.N Q
. . S SQ2="" F SQ2=0:1:5 S DATA(13,SQ1,SQ2)=$G(^IBT(356.22,IBTRNO,13,SQ1,SQ2))
;
I $D(^IBT(356.22,IBTRNO,14)) D ; Patient Event Transport Multiple.
. S SQ="" F S SQ=$O(^IBT(356.22,IBTRNO,14,SQ)) Q:SQ="" S DATA(14,SQ,0)=$G(^IBT(356.22,IBTRNO,14,SQ,0))
;
I $D(^IBT(356.22,IBTRNO,15)) D ; Other UMO Multiple.
. S SQ="" F S SQ=$O(^IBT(356.22,IBTRNO,15,SQ)) Q:SQ="" S DATA(15,SQ,0)=$G(^IBT(356.22,IBTRNO,15,SQ,0))
;
;
I $D(^IBT(356.22,IBTRNO,16)) D ; Service Line Multiple.
. S SQ1=0 S DATA(16,0)=$G(^IBT(356.22,IBTRNO,16,0))
. F S SQ1=$O(^IBT(356.22,IBTRNO,16,SQ1)) Q:SQ1="" D ; Service Line Item.
. . I SQ1'?.N Q
. . S DATA(16,SQ1,0)=$G(^IBT(356.22,IBTRNO,16,SQ1,0))
. . S SQ2=0 F S SQ2=$O(^IBT(356.22,IBTRNO,16,SQ1,SQ2)) Q:SQ2="" D ; Service Line Item sub-record.
. . . I SQ2'?.N Q
. . . I "^4^6^7^8^10^"[(U_SQ2_U) D Q ; Service Line Item sub-record is a multiple.
. . . . ; (i.e., ^IBT(356.22,IBTRNO,16,1,6,0))
. . . . S DATA(16,SQ1,SQ2,0)=$G(^IBT(356.22,IBTRNO,SQ1,SQ2,0))
. . . . S SQ3=0 F S SQ3=$O(^IBT(356.22,IBTRNO,16,SQ1,SQ2,SQ3)) Q:SQ3="" D
. . . . . I SQ3'?.N Q
. . . . . ; (i.e., ^IBT(356.22,IBTRNO,16,1,6,1,0))
. . . . . S DATA(16,SQ1,SQ2,SQ3,0)=$G(^IBT(356.22,IBTRNO,16,SQ1,SQ2,SQ3,0))
. . . . . S SQ4="" F S SQ4=$O(^IBT(356.22,IBTRNO,16,SQ1,SQ2,SQ3,SQ4)) Q:SQ4="" D
. . . . . . I SQ4'?.N Q
. . . . . . ; (ie., ^IBT(356.22,IBTRNO,16,1,8,1,0-5,0))
. . . . . . S DATA(16,SQ1,SQ2,SQ3,SQ4,0)=$G(^IBT(356.22,IBTRNO,16,SQ1,SQ2,SQ3,SQ4,0))
. . . . Q
. . . ; These sub-records are not multiples.
. . . S DATA(16,SQ1,SQ2)=$G(^IBT(356.22,IBTRNO,16,SQ1,SQ2)) ; This is true of sub-records 0,1,2,3,5,7,9,11.
;
;
S DATA(17)=$G(^IBT(356.22,IBTRNO,17))
S DATA(18)=$G(^IBT(356.22,IBTRNO,18))
S DATA(19)=$G(^IBT(356.22,IBTRNO,19))
S DATA(20)=$G(^IBT(356.22,IBTRNO,20))
S DATA(21)=$G(^IBT(356.22,IBTRNO,21))
S DATA(22)=$G(^IBT(356.22,IBTRNO,22))
;
I $D(^IBT(356.22,IBTRNO,101)) D ; AAA Segment Multiple.
. S SQ=0 S DATA(101,0)=$G(^IBT(356.22,IBTRNO,101,0))
. F S SQ=$O(^IBT(356.22,IBTRNO,101,SQ)) Q:SQ="" S DATA(101,SQ,0)=$G(^IBT(356.22,IBTRNO,101,SQ,0))
;
S DATA(103,0)=$G(^IBT(356.22,IBTRNO,103))
;
I $D(^IBT(356.22,IBTRNO,105)) D ; TRN Segment Multiple.
. S SQ=0 S DATA(105,0)=$G(^IBT(356.22,IBTRNO,105,0))
. F S SQ=$O(^IBT(356.22,IBTRNO,105,SQ)) Q:SQ="" S DATA(105,SQ,0)=$G(^IBT(356.22,IBTRNO,105,SQ,0))
;
I $D(^IBT(356.22,IBTRNO,107)) D ; HI Segment Multiple.
. S SQ=0 S DATA(107,0)=$G(^IBT(356.22,IBTRNO,107,0))
. F S SQ=$O(^IBT(356.22,IBTRNO,107,SQ)) Q:SQ="" S DATA(107,SQ,0)=$G(^IBT(356.22,IBTRNO,107,SQ,0))
Q
;
BLD ; charges, as they would display on the bill
S VALMCNT=0
D EN2^IBTRH2(IBTRNM,IBTRIEN) ; Get the Group Insurance information.
D GETINFO^IBTRH3A(IBTRNM,IBTRIEN)
Q
;
NODP ; No Response Pending for this selection.
D FULL^VALM1
W !!," No Response Pending to view."
D PAUSE^VALM1 S VALMBCK="R"
Q
;
SETDLN(DLN,SPEC) ; Add Display Line to ^TMP global.
S VALMCNT=VALMCNT+1
S ^TMP(IBTRNM,$J,VALMCNT,0)=DLN
I $G(SPEC)="B" D CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM)
Q
;
GTXNMY(VARPTR) ; API to obtain a Provider's Taxonomy Code and Person Class.
; INPUT: VARPTR is the variable pointer to the Provider.
; It can point to 1 of the 3 following globals:
; "ien;VA(200" points to the VA Individual Provider global
; "ien;DIC(4" points to the VA Institutional Provider global
; "ien;IBA(355.93" points to the non-VA Provider global
; where the ien is the internal identifier to the specified global.
;
; OUTPUT: TAXNMY will contain Taxonomy Results in 2 pieces:
; Piece 1: will contain the Taxonomy Code
; Piece 2: will contain the Person Class Description.
N RESULTS,TAXNMY,PC1,PC2
S (RESULTS,TAXNMY)=""
S PC1=$P(VARPTR,";",1),PC2=$P(VARPTR,";",2)
I PC2["VA(200" S RESULTS=$$TAXIND^XUSTAX(PC1) ; Get Taxonomy for VA Individual Provider
I PC2["DIC(4" S RESULTS=$$TAXORG^XUSTAX(PC1) ; Get Taxonomy for VA Institutional Provider
I PC2["IBA(355.93" S RESULTS=$$TAXGET^IBCEP81(PC1) ; Get Taxonomy for Non-VA Provider
I '+$P(RESULTS,U,2) Q TAXNMY
S TAXNMY=$P(RESULTS,U,1) ; Taxonomy Code
S $P(TAXNMY,U,2)=$$GET1^DIQ(8932.1,+$P(RESULTS,U,2),.01) ; Person Class description
Q TAXNMY
;
HELP ; -- help code
D FULL^VALM1
W !!,"This option displays the view of a Healthcare Services Review Response."
D PAUSE^VALM1 S VALMBCK="R"
Q
;
EXIT ; -- exit code
K ^TMP("IBTRH3",$J)
D CLEAR^VALM1,CLEAN^VALM10
Q
;
PRMARK(WHICH) ;EP
; Listman Protocol Action to Mark/Remove 'In-Progress' from a selected entry
; from the expand entry worklist
; Input: WHICH - 0 - Remove 'In-Progress' mark
; 1 - Set 'In-Progress' mark
; IBTRIEN - IEN of the Expanded Entry being marked/removed
N STATUS
D PRMARK^IBTRH1(WHICH,IBTRIEN,"IBTRH5IX")
S STATUS=$$GET1^DIQ(356.22,IBTRIEN_",",.21,"I")
I WHICH=1 D Q
. I +STATUS=1 S VALMSG="Entry has been Marked" Q
. S VALMSG="Nothing Done"
;
I +STATUS=0 S VALMSG="Entry has been Unmarked" Q
S VALMSG="Nothing Done"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRH3 12507 printed Sep 23, 2025@20:04:25 Page 2
IBTRH3 ;ALB/VAD - IBT HCSR RESPONSE VIEW ;02-JUN-2014
+1 ;;2.0;INTEGRATED BILLING;**517**;21-MAR-94;Build 240
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; -- main entry point for IBT HCSR Response View
+1 NEW IBPTNO,IBTRIEN,IBOK,DATA,IBTRNM,IBTRSPEC
+2 NEW DFN,NODE0,IEN312,INSNODE0,VALMCNT
+3 SET IBTRNM="IBTRH3"
+4 ;
+5 DO EN^VALM("IBT HCSR RESPONSE VIEW")
+6 IF $GET(IBPTNO)'=-1
IF '$DATA(IBFASTXT)
KILL IBTNO,IBTRIEN,IBOK,DATA,IBTRN,IBTRSPEC,DFN,NODE0,IEN312,INSNODE0,VALMCNT
GOTO EN
+7 QUIT
+8 ;
EN2 ;JWS;alternate entry point when IBTRIEN is selected from
+1 ; a response list view, so IBTRIEN is known
+2 NEW DLINE,IBPTNO,IBTRIEN,IBOK,DATA,IBTRNM,IBTRSPEC
+3 NEW DFN,NODE0,IEN312,INSNODE0,VALMCNT
+4 SET IBTRNM="IBTRH3"
+5 ; select entry to expand
SET IBTRIEN=+$$SELEVENT^IBTRH5(0,"Select entry",.DLINE)
+6 IF IBTRIEN'>0
QUIT
+7 DO EN^VALM("IBT HCSR RESPONSE VIEW")
+8 QUIT
+9 ;
EN3 ;alternate entry point when IBTRIEN is selected from
+1 ; a response list view to display response pending entry,
+2 ; so IBTRIEN is known for the current entry and we need
+3 ; to figure out the pending response.
+4 NEW CURIEN,CURNODE0
+5 SET CURIEN=IBTRIEN
+6 SET CURNODE0=NODE0
+7 ;
+8 NEW DLINE,IBPTNO,IBTRIEN,IBOK,DATA,IBTRNM,IBTRSPEC
+9 NEW DFN,NODE0,IEN312,INSNODE0,VALMCNT
+10 SET IBTRNM="IBTRH3"
+11 IF $PIECE(CURNODE0,U,8)'="07"
DO NODP
QUIT
+12 SET IBTRIEN=$PIECE(CURNODE0,U,14)
+13 IF IBTRIEN'>0
DO NODP
QUIT
+14 DO EN^VALM("IBT HCSR RESPONSE VIEW")
+15 QUIT
+16 ;
HDR ; -- header code
+1 NEW VADM,Z
+2 SET Z=""
+3 IF +$GET(DFN)
DO DEM^VADPT
SET Z=$EXTRACT(VADM(1),1,28)
SET Z=Z_$JUSTIFY("",35-$LENGTH(Z))_$PIECE(VADM(2),U,2)_" DOB: "_$PIECE(VADM(3),U,2)_" AGE: "_VADM(4)
+4 SET VALMHDR(1)=Z
+5 SET VALMSG="#In-Prog"
+6 QUIT
+7 ;
INIT ; -- init variables and list array
+1 ;JWS 9/9/14 - added conditions based on IBTRIEN already selected
+2 KILL ^TMP(IBTRNM,$JOB)
+3 ;
+4 ; May need a switch or 2 to call INIT^IBTRH2 one to not display comments and
+5 ; maybe another to change the primary subscript from "IBTRH2" to something else
+6 ;
+7 ; JWS 9/9/14 - if response IEN has value, set PATIENT variable and skip forward
+8 IF +$GET(IBTRIEN)
SET IBPTNO=$PIECE($GET(^IBT(356.22,IBTRIEN,0)),U,2)
GOTO INIT1
+9 ; Get the Patient.
+10 SET IBPTNO=$$ASKPAT()
IF IBPTNO=-1
SET VALMQUIT=""
GOTO INITQ
+11 IF '$DATA(^IBT(356.22,"D",IBPTNO))
Begin DoDot:1
+12 WRITE !,"No HCSR Response data for this Patient.",!
End DoDot:1
GOTO INIT
+13 ;
+14 ; Get the Appointment/Admission Date.
+15 SET IBTRIEN=$$ASKEVT(IBPTNO)
+16 IF IBTRIEN=-1
SET VALMQUIT=""
GOTO INITQ
+17 IF '$GET(IBTRIEN)
SET VALMQUIT=""
GOTO INITQ
INIT1 ;
+1 SET IBTRSPEC("IBTPATID")=IBPTNO
+2 SET IBTRSPEC("IBTEVENT")=IBTRIEN
+3 ;
+4 SET NODE0=$GET(^IBT(356.22,IBTRIEN,0))
+5 SET DFN=+$PIECE(NODE0,U,2)
+6 SET IEN312=+$PIECE(NODE0,U,3)
+7 ; 0-node in file 2.312
SET INSNODE0=""
if IEN312>0
SET INSNODE0=$GET(^DPT(DFN,.312,IEN312,0))
+8 ;
+9 ; Compile the data for the display.
+10 DO COMPILE(IBTRNM,.IBTRSPEC)
INITQ QUIT
+1 ;
ASKPAT() ; Get the Patient Name
+1 ; Init vars
+2 NEW DIC,DTOUT,DUOUT,X,Y
+3 ; Patient lookup
+4 WRITE !
+5 SET DIC(0)="AEQM"
SET DIC("S")="I $D(^IBT(356.22,""D"",Y))"
+6 SET DIC("A")=$$FO^IBCNEUT1("Select PATIENT NAME: ",21,"R")
+7 SET DIC="^DPT("
+8 DO ^DIC
+9 QUIT +Y
+10 ;
ASKEVT(IBTRIEN) ; Get the Appointment/Admission
+1 NEW A1,A2,MX,SEL,YY,XIEN,XREQ,XREQDATA
+2 ; If no Appts Quit.
SET YY=$$GTLIST(IBTRIEN)
IF YY=-1
DO NODP
GOTO ASKEVTX
ASKEVT1 ;
+1 SET A1=""
SET MX=0
+2 WRITE !!!,"Select Appt/Adm:",!
+3 ; Loop through the list if Appointments/Admissions and display each one.
+4 FOR
SET A1=$ORDER(^TMP("IBTRH3E",$JOB,"XLISTNO",A1))
if A1=""
QUIT
SET A2=$PIECE(^(A1),"^",3)
Begin DoDot:1
+5 SET XIEN=+$GET(^TMP("IBTRH3E",$JOB,"DILIST",2,A2))
+6 SET XREQ=+$PIECE($GET(^IBT(356.22,XIEN,0)),"^",13)
SET XREQDATA=$GET(^IBT(356.22,XREQ,0))
+7 WRITE !?5,A1,". ",$SELECT($PIECE(XREQDATA,"^",4)="I":"Adm: ",1:"App: ")
+8 WRITE $$FMTE^XLFDT($PIECE(^TMP("IBTRH3E",$JOB,"XLISTNO",A1),U,1))," "
+9 WRITE $SELECT($PIECE(XREQDATA,"^",20)=1:"215:",1:"217:")
SET MX=A1
+10 WRITE " ",$$FMTE^XLFDT($PIECE($PIECE(XREQDATA,U,15),"."))," "
+11 IF $PIECE($GET(^IBT(356.22,XIEN,103)),"^")
WRITE $$GET1^DIQ(356.22,XIEN_",",103.01)
+12 IF '$TEST
IF $DATA(^IBT(356.22,XIEN,101))
WRITE "AAA"
End DoDot:1
+13 ; Nothing selected.
READ !,"Enter Selection: ",SEL:DTIME
IF SEL=""!(SEL="^")
SET YY=-1
GOTO ASKEVTX
+14 IF SEL<1!(SEL>MX)
WRITE !?5,"INVALID SELECTION.",!
GOTO ASKEVT1
+15 SET YY=$PIECE($GET(^TMP("IBTRH3E",$JOB,"XLISTNO",SEL)),U,3)
+16 SET YY=+$GET(^TMP("IBTRH3E",$JOB,"DILIST",2,YY))
+17 IF YY=0
SET YY=-1
ASKEVTX QUIT YY
+1 ;
GTLIST(IBTRIEN) ; Create list of Appointments/Admission Dates.
+1 ; This will create a ^TMP global that will look similar to the following:
+2 ; ^TMP("IBTRH3E",$J,"DILIST",0)="1^*^0^"
+3 ; ^TMP("IBTRH3E",$J,"DILIST",0,"MAP")=.07
+4 ; ^TMP("IBTRH3E",$J,"DILIST",I1,J)="JUN 19, 2014@11:00"
+5 ; ^TMP("IBTRH3E",$J,"DILIST",I2,J)=IBTRNO
+6 ; ^TMP("IBTRH3E",$J,"DILIST","ID",J,.07)=IBTEVNT
+7 ; where:
+8 ; I1 = The first cross-reference index which has the external event date values to display.
+9 ; I2 = The second cross-reference index which has the pointers to the IBT(356.22,...) Record no.
+10 ; J = Is just the internal counter of events for the selected patient.
+11 ; And ^IBT(356.22,"D",IBTRIEN,IBTEVNT,IBTRNO) is the actual Cross-reference record.
+12 ;
+13 NEW A,B,X,Z,Z1
+14 SET X=-1
+15 KILL ^TMP("IBTRH3E",$JOB)
+16 ; Only want Responses for the selected Patient.
+17 DO LIST^DIC(356.22,,".07",,,,,,"I $P(^(0),U,2)=IBTRIEN,$P(^(0),U,20)=2",,"^TMP(""IBTRH3E"",$J)")
+18 IF +$PIECE($GET(^TMP("IBTRH3E",$JOB,"DILIST",0)),U,1)
Begin DoDot:1
+19 SET A=""
+20 FOR
SET A=$ORDER(^TMP("IBTRH3E",$JOB,"DILIST","ID",A))
if A=""
QUIT
Begin DoDot:2
+21 SET B=^(A,.07)
SET ^TMP("IBTRH3E",$JOB,"XLIST",B,$GET(^TMP("IBTRH3E",$JOB,"DILIST",1,A)))=A
End DoDot:2
+22 SET Z=0
SET (A,B)=""
+23 ; Appt/Adm
FOR
SET A=$ORDER(^TMP("IBTRH3E",$JOB,"XLIST",A))
if A=""
QUIT
Begin DoDot:2
+24 SET B=""
+25 ; Date Entered
FOR
SET B=$ORDER(^TMP("IBTRH3E",$JOB,"XLIST",A,B))
if B=""
QUIT
SET Z1=$GET(^(B))
Begin DoDot:3
+26 SET Z=Z+1
+27 SET ^TMP("IBTRH3E",$JOB,"XLISTNO",Z)=A_U_B_U_Z1
End DoDot:3
End DoDot:2
+28 SET X=1
End DoDot:1
+29 QUIT X
+30 ;
COMPILE(IBTRNM,IBTRSPEC) ; -- Compile the data
+1 KILL ^TMP(IBTRNM,$JOB)
+2 ;
+3 ; Compile Data
+4 DO SETDATA
DO BLD
+5 QUIT
+6 ;
SETDATA ; -- Set up the data
+1 NEW SQ,SQ1,SQ2,SQ3,SQ4,X,IBTRNO
+2 SET IBTRNO=IBTRSPEC("IBTEVENT")
+3 SET DATA(0)=$GET(^IBT(356.22,IBTRNO,0))
+4 ;
+5 ; Comments Multiple.
IF $DATA(^IBT(356.22,IBTRNO,1))
Begin DoDot:1
+6 SET SQ=""
FOR
SET SQ=$ORDER(^IBT(356.22,IBTRNO,1,SQ))
if SQ=""
QUIT
SET DATA(1,SQ,0)=$GET(^IBT(356.22,IBTRNO,1,SQ,0))
End DoDot:1
+7 ;
+8 SET DATA(2)=$GET(^IBT(356.22,IBTRNO,2))
+9 ;
+10 ; Patient Diagnosis Multiple.
IF $DATA(^IBT(356.22,IBTRNO,3))
Begin DoDot:1
+11 SET SQ=0
FOR
SET SQ=$ORDER(^IBT(356.22,IBTRNO,3,SQ))
if SQ=""
QUIT
SET DATA(3,SQ,0)=$GET(^IBT(356.22,IBTRNO,3,SQ,0))
End DoDot:1
+12 ;
+13 SET DATA(4)=$GET(^IBT(356.22,IBTRNO,4))
+14 SET DATA(7)=$GET(^IBT(356.22,IBTRNO,7))
+15 SET DATA(8)=$GET(^IBT(356.22,IBTRNO,8))
+16 SET DATA(9)=$GET(^IBT(356.22,IBTRNO,9))
+17 SET DATA(10)=$GET(^IBT(356.22,IBTRNO,10))
+18 ;
+19 ; Attachments Multiple.
IF $DATA(^IBT(356.22,IBTRNO,11))
Begin DoDot:1
+20 SET SQ=0
FOR
SET SQ=$ORDER(^IBT(356.22,IBTRNO,11,SQ))
if (SQ="")!('+SQ)
QUIT
SET DATA(11,SQ,0)=$GET(^IBT(356.22,IBTRNO,11,SQ,0))
End DoDot:1
+21 ;
+22 IF $DATA(^IBT(356.22,IBTRNO,12))
Begin DoDot:1
+23 NEW SQ1,TEXT
+24 SET SQ=0
FOR
SET SQ=$ORDER(^IBT(356.22,IBTRNO,12,SQ))
if SQ=""
QUIT
Begin DoDot:2
+25 SET TEXT=$GET(^IBT(356.22,IBTRNO,12,SQ,0))
+26 IF $LENGTH(TEXT)>80
Begin DoDot:3
+27 NEW SAV,X1,END
+28 SET END=$LENGTH(TEXT," ")
+29 FOR I=1:1:END
SET X1=$PIECE(TEXT," ",I)
Begin DoDot:4
+30 IF X1=""
IF $GET(SAV)=""
QUIT
+31 IF X1=""
SET X1=" "
+32 IF $LENGTH(X1)+$LENGTH($GET(SAV))<78
if $GET(SAV)'=""
SET SAV=SAV_" "
SET SAV=$GET(SAV)_X1
QUIT
+33 SET SQ1=$GET(SQ1)+1
SET DATA(12,SQ1)=SAV
SET SAV=X1
End DoDot:4
+34 IF $GET(SAV)'=""
SET SQ1=$GET(SQ1)+1
SET DATA(12,SQ1)=SAV
+35 SET DATA(12,0)=SQ1
End DoDot:3
QUIT
+36 SET SQ1=$GET(SQ1)+1
SET DATA(12,SQ1)=TEXT
+37 SET DATA(12,0)=+SQ1
End DoDot:2
End DoDot:1
+38 ;
+39 ; Patient Event Provider Multiple.
IF $DATA(^IBT(356.22,IBTRNO,13))
Begin DoDot:1
+40 SET SQ1=0
FOR
SET SQ1=$ORDER(^IBT(356.22,IBTRNO,13,SQ1))
if SQ1=""
QUIT
Begin DoDot:2
+41 IF SQ1'?.N
QUIT
+42 SET SQ2=""
FOR SQ2=0:1:5
SET DATA(13,SQ1,SQ2)=$GET(^IBT(356.22,IBTRNO,13,SQ1,SQ2))
End DoDot:2
End DoDot:1
+43 ;
+44 ; Patient Event Transport Multiple.
IF $DATA(^IBT(356.22,IBTRNO,14))
Begin DoDot:1
+45 SET SQ=""
FOR
SET SQ=$ORDER(^IBT(356.22,IBTRNO,14,SQ))
if SQ=""
QUIT
SET DATA(14,SQ,0)=$GET(^IBT(356.22,IBTRNO,14,SQ,0))
End DoDot:1
+46 ;
+47 ; Other UMO Multiple.
IF $DATA(^IBT(356.22,IBTRNO,15))
Begin DoDot:1
+48 SET SQ=""
FOR
SET SQ=$ORDER(^IBT(356.22,IBTRNO,15,SQ))
if SQ=""
QUIT
SET DATA(15,SQ,0)=$GET(^IBT(356.22,IBTRNO,15,SQ,0))
End DoDot:1
+49 ;
+50 ;
+51 ; Service Line Multiple.
IF $DATA(^IBT(356.22,IBTRNO,16))
Begin DoDot:1
+52 SET SQ1=0
SET DATA(16,0)=$GET(^IBT(356.22,IBTRNO,16,0))
+53 ; Service Line Item.
FOR
SET SQ1=$ORDER(^IBT(356.22,IBTRNO,16,SQ1))
if SQ1=""
QUIT
Begin DoDot:2
+54 IF SQ1'?.N
QUIT
+55 SET DATA(16,SQ1,0)=$GET(^IBT(356.22,IBTRNO,16,SQ1,0))
+56 ; Service Line Item sub-record.
SET SQ2=0
FOR
SET SQ2=$ORDER(^IBT(356.22,IBTRNO,16,SQ1,SQ2))
if SQ2=""
QUIT
Begin DoDot:3
+57 IF SQ2'?.N
QUIT
+58 ; Service Line Item sub-record is a multiple.
IF "^4^6^7^8^10^"[(U_SQ2_U)
Begin DoDot:4
+59 ; (i.e., ^IBT(356.22,IBTRNO,16,1,6,0))
+60 SET DATA(16,SQ1,SQ2,0)=$GET(^IBT(356.22,IBTRNO,SQ1,SQ2,0))
+61 SET SQ3=0
FOR
SET SQ3=$ORDER(^IBT(356.22,IBTRNO,16,SQ1,SQ2,SQ3))
if SQ3=""
QUIT
Begin DoDot:5
+62 IF SQ3'?.N
QUIT
+63 ; (i.e., ^IBT(356.22,IBTRNO,16,1,6,1,0))
+64 SET DATA(16,SQ1,SQ2,SQ3,0)=$GET(^IBT(356.22,IBTRNO,16,SQ1,SQ2,SQ3,0))
+65 SET SQ4=""
FOR
SET SQ4=$ORDER(^IBT(356.22,IBTRNO,16,SQ1,SQ2,SQ3,SQ4))
if SQ4=""
QUIT
Begin DoDot:6
+66 IF SQ4'?.N
QUIT
+67 ; (ie., ^IBT(356.22,IBTRNO,16,1,8,1,0-5,0))
+68 SET DATA(16,SQ1,SQ2,SQ3,SQ4,0)=$GET(^IBT(356.22,IBTRNO,16,SQ1,SQ2,SQ3,SQ4,0))
End DoDot:6
End DoDot:5
+69 QUIT
End DoDot:4
QUIT
+70 ; These sub-records are not multiples.
+71 ; This is true of sub-records 0,1,2,3,5,7,9,11.
SET DATA(16,SQ1,SQ2)=$GET(^IBT(356.22,IBTRNO,16,SQ1,SQ2))
End DoDot:3
End DoDot:2
End DoDot:1
+72 ;
+73 ;
+74 SET DATA(17)=$GET(^IBT(356.22,IBTRNO,17))
+75 SET DATA(18)=$GET(^IBT(356.22,IBTRNO,18))
+76 SET DATA(19)=$GET(^IBT(356.22,IBTRNO,19))
+77 SET DATA(20)=$GET(^IBT(356.22,IBTRNO,20))
+78 SET DATA(21)=$GET(^IBT(356.22,IBTRNO,21))
+79 SET DATA(22)=$GET(^IBT(356.22,IBTRNO,22))
+80 ;
+81 ; AAA Segment Multiple.
IF $DATA(^IBT(356.22,IBTRNO,101))
Begin DoDot:1
+82 SET SQ=0
SET DATA(101,0)=$GET(^IBT(356.22,IBTRNO,101,0))
+83 FOR
SET SQ=$ORDER(^IBT(356.22,IBTRNO,101,SQ))
if SQ=""
QUIT
SET DATA(101,SQ,0)=$GET(^IBT(356.22,IBTRNO,101,SQ,0))
End DoDot:1
+84 ;
+85 SET DATA(103,0)=$GET(^IBT(356.22,IBTRNO,103))
+86 ;
+87 ; TRN Segment Multiple.
IF $DATA(^IBT(356.22,IBTRNO,105))
Begin DoDot:1
+88 SET SQ=0
SET DATA(105,0)=$GET(^IBT(356.22,IBTRNO,105,0))
+89 FOR
SET SQ=$ORDER(^IBT(356.22,IBTRNO,105,SQ))
if SQ=""
QUIT
SET DATA(105,SQ,0)=$GET(^IBT(356.22,IBTRNO,105,SQ,0))
End DoDot:1
+90 ;
+91 ; HI Segment Multiple.
IF $DATA(^IBT(356.22,IBTRNO,107))
Begin DoDot:1
+92 SET SQ=0
SET DATA(107,0)=$GET(^IBT(356.22,IBTRNO,107,0))
+93 FOR
SET SQ=$ORDER(^IBT(356.22,IBTRNO,107,SQ))
if SQ=""
QUIT
SET DATA(107,SQ,0)=$GET(^IBT(356.22,IBTRNO,107,SQ,0))
End DoDot:1
+94 QUIT
+95 ;
BLD ; charges, as they would display on the bill
+1 SET VALMCNT=0
+2 ; Get the Group Insurance information.
DO EN2^IBTRH2(IBTRNM,IBTRIEN)
+3 DO GETINFO^IBTRH3A(IBTRNM,IBTRIEN)
+4 QUIT
+5 ;
NODP ; No Response Pending for this selection.
+1 DO FULL^VALM1
+2 WRITE !!," No Response Pending to view."
+3 DO PAUSE^VALM1
SET VALMBCK="R"
+4 QUIT
+5 ;
SETDLN(DLN,SPEC) ; Add Display Line to ^TMP global.
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP(IBTRNM,$JOB,VALMCNT,0)=DLN
+3 IF $GET(SPEC)="B"
DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM)
+4 QUIT
+5 ;
GTXNMY(VARPTR) ; API to obtain a Provider's Taxonomy Code and Person Class.
+1 ; INPUT: VARPTR is the variable pointer to the Provider.
+2 ; It can point to 1 of the 3 following globals:
+3 ; "ien;VA(200" points to the VA Individual Provider global
+4 ; "ien;DIC(4" points to the VA Institutional Provider global
+5 ; "ien;IBA(355.93" points to the non-VA Provider global
+6 ; where the ien is the internal identifier to the specified global.
+7 ;
+8 ; OUTPUT: TAXNMY will contain Taxonomy Results in 2 pieces:
+9 ; Piece 1: will contain the Taxonomy Code
+10 ; Piece 2: will contain the Person Class Description.
+11 NEW RESULTS,TAXNMY,PC1,PC2
+12 SET (RESULTS,TAXNMY)=""
+13 SET PC1=$PIECE(VARPTR,";",1)
SET PC2=$PIECE(VARPTR,";",2)
+14 ; Get Taxonomy for VA Individual Provider
IF PC2["VA(200"
SET RESULTS=$$TAXIND^XUSTAX(PC1)
+15 ; Get Taxonomy for VA Institutional Provider
IF PC2["DIC(4"
SET RESULTS=$$TAXORG^XUSTAX(PC1)
+16 ; Get Taxonomy for Non-VA Provider
IF PC2["IBA(355.93"
SET RESULTS=$$TAXGET^IBCEP81(PC1)
+17 IF '+$PIECE(RESULTS,U,2)
QUIT TAXNMY
+18 ; Taxonomy Code
SET TAXNMY=$PIECE(RESULTS,U,1)
+19 ; Person Class description
SET $PIECE(TAXNMY,U,2)=$$GET1^DIQ(8932.1,+$PIECE(RESULTS,U,2),.01)
+20 QUIT TAXNMY
+21 ;
HELP ; -- help code
+1 DO FULL^VALM1
+2 WRITE !!,"This option displays the view of a Healthcare Services Review Response."
+3 DO PAUSE^VALM1
SET VALMBCK="R"
+4 QUIT
+5 ;
EXIT ; -- exit code
+1 KILL ^TMP("IBTRH3",$JOB)
+2 DO CLEAR^VALM1
DO CLEAN^VALM10
+3 QUIT
+4 ;
PRMARK(WHICH) ;EP
+1 ; Listman Protocol Action to Mark/Remove 'In-Progress' from a selected entry
+2 ; from the expand entry worklist
+3 ; Input: WHICH - 0 - Remove 'In-Progress' mark
+4 ; 1 - Set 'In-Progress' mark
+5 ; IBTRIEN - IEN of the Expanded Entry being marked/removed
+6 NEW STATUS
+7 DO PRMARK^IBTRH1(WHICH,IBTRIEN,"IBTRH5IX")
+8 SET STATUS=$$GET1^DIQ(356.22,IBTRIEN_",",.21,"I")
+9 IF WHICH=1
Begin DoDot:1
+10 IF +STATUS=1
SET VALMSG="Entry has been Marked"
QUIT
+11 SET VALMSG="Nothing Done"
End DoDot:1
QUIT
+12 ;
+13 IF +STATUS=0
SET VALMSG="Entry has been Unmarked"
QUIT
+14 SET VALMSG="Nothing Done"
+15 QUIT
+16 ;
