IBMHSP1 ;EDE/SAB-MENTAL HEALTH VISIT INQUIRY Part 2 ; 29-NOV-19
;;2.0;INTEGRATED BILLING;**784**;21-MAR-94;Build 8
;; Per VHA Directive 6402, this routine should not be modified
;
Q
;
; Prints report to the current device
;
; Input:
; IBDFN - Patient IEN
; IBDT1 - Beginning date
; IBDT2 - Ending date
; Output:
; IBQUIT = 1, if user entered "^" (Devices starting with "C-" only)
REPORT ;
N IBDT,IBVSIEN,IBDATA,IBYR,IBSQNO,IBI
N IBSITE,IBSTAT,IBBLNO,IBREAS
S IBQUIT=0
;
;Gather the visits within the year range into to a sorted temporary array
S IBVSIEN=0
F S IBVSIEN=$O(^IBMH(351.83,"B",IBDFN,IBVSIEN)) Q:'IBVSIEN D
. S IBDATA=$G(^IBMH(351.83,IBVSIEN,0)),IBDT=$P(IBDATA,U,3)
. ;convert date to year format for comparison.
. S IBYR=$E(IBDT,1,3)+1700
. Q:IBYR<IBDT1 ; Visit date before year range start
. Q:IBYR>IBDT2 ; Visit date after year range end
. ; find visit number so we don't overwrite multiple visits on same day
. S (IBSQNO,IBI)=0 F S IBI=$O(^TMP($J,"IBMHSP",IBYR,IBDT,IBI)) Q:'IBI Q:'$D(^TMP($J,"IBMHSP",IBYR,IBDT,IBI)) S (IBI,IBSQNO)=IBSQNO+1
. S IBSQNO=IBSQNO+1
. ;CONVERT THE POINTER AND CODES TO TEXTINFO TO TEXT.
. S IBSITE=$$GET1^DIQ(351.83,IBVSIEN_",",.02,"E")
. S IBSTAT=$$GET1^DIQ(351.83,IBVSIEN_",",.04,"E")
. S IBBLNO=$P(IBDATA,U,5)
. S IBREAS=$$GET1^DIQ(351.83,IBVSIEN_",",.06,"E")
. S ^TMP($J,"IBMHSP",IBYR,IBDT,IBSQNO)=IBDT_U_$E(IBSITE,1,18)_U_IBSTAT_U_IBBLNO_U_IBREAS
;
D PRINT
K ^TMP($J,"IBMHSP")
S:$D(ZTQUEUED) ZTREQ="@" ; for Taskman
Q
;
PRINT ; Print report from the temp. global (cONVERT TO EXTERNAL DATA)
N IBDTH,IBLINE,IBPAG,IBYR,IBDT,IBSQNO,IBDATA,IBH,IBPT
D NOW^%DTC S IBDTH=$$FMTE^XLFDT($E(%,1,12))
S IBLINE="",$P(IBLINE,"=",IOM+1)="",(IBPAG,IBQUIT)=0
S IBPT=$$PT^IBEFUNC(IBDFN)
S IBH="Mental Health Visit Profile for "_$P(IBPT,U) D HDR
I '$D(^TMP($J,"IBMHSP")) W !!,"The patient has no Mental Health Visits within the specified period" D PAUSE(1) Q
S IBYR=0
F S IBYR=$O(^TMP($J,"IBMHSP",IBYR)) Q:'IBYR D Q:IBQUIT
. S IBDT=0
. W !,IBYR,!,"----"
. F S IBDT=$O(^TMP($J,"IBMHSP",IBYR,IBDT)) Q:IBDT="" D Q:IBQUIT
. . D CHKSTOP ; Pause at the end of each screen page. Allow user to exit. Returns IBQUIT
. . Q:IBQUIT
. . S IBSQNO=0
. . F S IBSQNO=$O(^TMP($J,"IBMHSP",IBYR,IBDT,IBSQNO)) Q:IBSQNO="" D Q:IBQUIT
. . . D CHKSTOP ; Pause at the end of each screen page. Allow user to exit. Returns IBQUIT
. . . Q:IBQUIT
. . . S IBDATA=$G(^TMP($J,"IBMHSP",IBYR,IBDT,IBSQNO))
. . . Q:$G(IBDATA)=""
. . . W !,$$FMTE^XLFDT($P(IBDATA,U,1)),?15,$P(IBDATA,U,2),?35,$P(IBDATA,U,3),?47,$P(IBDATA,U,4),?60,$P(IBDATA,U,5)
. ; print a separator between years.
. W !
Q:IBQUIT
D PAUSE(1)
Q
CHKSTOP I $Y>(IOSL-5) D PAUSE(0) Q:IBQUIT D HDR
Q
;
HDR ; Print header.
N IBI
I $E(IOST,1,2)["C-"!(IBPAG) W @IOF,*13
S IBPAG=IBPAG+1 W ?(80-$L(IBH)\2),IBH
W !,"From ",IBDT1," through ",IBDT2
W ?IOM-36,IBDTH,?IOM-9,"Page: ",IBPAG
W !,"VISIT DATE",?15,"SITE",?35,"STATUS",?47,"BILL NO.",?60,"REASON"
W ! F IBI=1:1:80 W "-"
Q
;
PAUSE(IBEND) ;
Q:$E(IOST,1,2)'["C-"
N IBJ,DIR,DIRUT,DTOUT,DUOUT,DIROUT,Y
W !! ;F IBJ=$Y:1:(IOSL-4) W !
S DIR(0)="E"
I $G(IBEND) S DIR("A")="End of the report. Enter RETURN to continue or '^' to exit"
D ^DIR K DIR I $G(DUOUT) S IBQUIT=1 W @IOF Q
I $G(IBEND) W @IOF
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBMHSP1 3411 printed Dec 13, 2024@02:24:29 Page 2
IBMHSP1 ;EDE/SAB-MENTAL HEALTH VISIT INQUIRY Part 2 ; 29-NOV-19
+1 ;;2.0;INTEGRATED BILLING;**784**;21-MAR-94;Build 8
+2 ;; Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
+6 ; Prints report to the current device
+7 ;
+8 ; Input:
+9 ; IBDFN - Patient IEN
+10 ; IBDT1 - Beginning date
+11 ; IBDT2 - Ending date
+12 ; Output:
+13 ; IBQUIT = 1, if user entered "^" (Devices starting with "C-" only)
REPORT ;
+1 NEW IBDT,IBVSIEN,IBDATA,IBYR,IBSQNO,IBI
+2 NEW IBSITE,IBSTAT,IBBLNO,IBREAS
+3 SET IBQUIT=0
+4 ;
+5 ;Gather the visits within the year range into to a sorted temporary array
+6 SET IBVSIEN=0
+7 FOR
SET IBVSIEN=$ORDER(^IBMH(351.83,"B",IBDFN,IBVSIEN))
if 'IBVSIEN
QUIT
Begin DoDot:1
+8 SET IBDATA=$GET(^IBMH(351.83,IBVSIEN,0))
SET IBDT=$PIECE(IBDATA,U,3)
+9 ;convert date to year format for comparison.
+10 SET IBYR=$EXTRACT(IBDT,1,3)+1700
+11 ; Visit date before year range start
if IBYR<IBDT1
QUIT
+12 ; Visit date after year range end
if IBYR>IBDT2
QUIT
+13 ; find visit number so we don't overwrite multiple visits on same day
+14 SET (IBSQNO,IBI)=0
FOR
SET IBI=$ORDER(^TMP($JOB,"IBMHSP",IBYR,IBDT,IBI))
if 'IBI
QUIT
if '$DATA(^TMP($JOB,"IBMHSP",IBYR,IBDT,IBI))
QUIT
SET (IBI,IBSQNO)=IBSQNO+1
+15 SET IBSQNO=IBSQNO+1
+16 ;CONVERT THE POINTER AND CODES TO TEXTINFO TO TEXT.
+17 SET IBSITE=$$GET1^DIQ(351.83,IBVSIEN_",",.02,"E")
+18 SET IBSTAT=$$GET1^DIQ(351.83,IBVSIEN_",",.04,"E")
+19 SET IBBLNO=$PIECE(IBDATA,U,5)
+20 SET IBREAS=$$GET1^DIQ(351.83,IBVSIEN_",",.06,"E")
+21 SET ^TMP($JOB,"IBMHSP",IBYR,IBDT,IBSQNO)=IBDT_U_$EXTRACT(IBSITE,1,18)_U_IBSTAT_U_IBBLNO_U_IBREAS
End DoDot:1
+22 ;
+23 DO PRINT
+24 KILL ^TMP($JOB,"IBMHSP")
+25 ; for Taskman
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+26 QUIT
+27 ;
PRINT ; Print report from the temp. global (cONVERT TO EXTERNAL DATA)
+1 NEW IBDTH,IBLINE,IBPAG,IBYR,IBDT,IBSQNO,IBDATA,IBH,IBPT
+2 DO NOW^%DTC
SET IBDTH=$$FMTE^XLFDT($EXTRACT(%,1,12))
+3 SET IBLINE=""
SET $PIECE(IBLINE,"=",IOM+1)=""
SET (IBPAG,IBQUIT)=0
+4 SET IBPT=$$PT^IBEFUNC(IBDFN)
+5 SET IBH="Mental Health Visit Profile for "_$PIECE(IBPT,U)
DO HDR
+6 IF '$DATA(^TMP($JOB,"IBMHSP"))
WRITE !!,"The patient has no Mental Health Visits within the specified period"
DO PAUSE(1)
QUIT
+7 SET IBYR=0
+8 FOR
SET IBYR=$ORDER(^TMP($JOB,"IBMHSP",IBYR))
if 'IBYR
QUIT
Begin DoDot:1
+9 SET IBDT=0
+10 WRITE !,IBYR,!,"----"
+11 FOR
SET IBDT=$ORDER(^TMP($JOB,"IBMHSP",IBYR,IBDT))
if IBDT=""
QUIT
Begin DoDot:2
+12 ; Pause at the end of each screen page. Allow user to exit. Returns IBQUIT
DO CHKSTOP
+13 if IBQUIT
QUIT
+14 SET IBSQNO=0
+15 FOR
SET IBSQNO=$ORDER(^TMP($JOB,"IBMHSP",IBYR,IBDT,IBSQNO))
if IBSQNO=""
QUIT
Begin DoDot:3
+16 ; Pause at the end of each screen page. Allow user to exit. Returns IBQUIT
DO CHKSTOP
+17 if IBQUIT
QUIT
+18 SET IBDATA=$GET(^TMP($JOB,"IBMHSP",IBYR,IBDT,IBSQNO))
+19 if $GET(IBDATA)=""
QUIT
+20 WRITE !,$$FMTE^XLFDT($PIECE(IBDATA,U,1)),?15,$PIECE(IBDATA,U,2),?35,$PIECE(IBDATA,U,3),?47,$PIECE(IBDATA,U,4),?60,$PIECE(IBDATA,U,5)
End DoDot:3
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
+21 ; print a separator between years.
+22 WRITE !
End DoDot:1
if IBQUIT
QUIT
+23 if IBQUIT
QUIT
+24 DO PAUSE(1)
+25 QUIT
CHKSTOP IF $Y>(IOSL-5)
DO PAUSE(0)
if IBQUIT
QUIT
DO HDR
+1 QUIT
+2 ;
HDR ; Print header.
+1 NEW IBI
+2 IF $EXTRACT(IOST,1,2)["C-"!(IBPAG)
WRITE @IOF,*13
+3 SET IBPAG=IBPAG+1
WRITE ?(80-$LENGTH(IBH)\2),IBH
+4 WRITE !,"From ",IBDT1," through ",IBDT2
+5 WRITE ?IOM-36,IBDTH,?IOM-9,"Page: ",IBPAG
+6 WRITE !,"VISIT DATE",?15,"SITE",?35,"STATUS",?47,"BILL NO.",?60,"REASON"
+7 WRITE !
FOR IBI=1:1:80
WRITE "-"
+8 QUIT
+9 ;
PAUSE(IBEND) ;
+1 if $EXTRACT(IOST,1,2)'["C-"
QUIT
+2 NEW IBJ,DIR,DIRUT,DTOUT,DUOUT,DIROUT,Y
+3 ;F IBJ=$Y:1:(IOSL-4) W !
WRITE !!
+4 SET DIR(0)="E"
+5 IF $GET(IBEND)
SET DIR("A")="End of the report. Enter RETURN to continue or '^' to exit"
+6 DO ^DIR
KILL DIR
IF $GET(DUOUT)
SET IBQUIT=1
WRITE @IOF
QUIT
+7 IF $GET(IBEND)
WRITE @IOF
+8 QUIT
+9 ;
