IBUCSP ;WOIFO/AAT-URGENT CARE SINGLE PATIENT PROFILE ; 20-FEB-02
;;2.0;INTEGRATED BILLING;**663,671**;21-MAR-94;Build 13
;; Per VHA Directive 6402, this routine should not be modified
;
Q
;
ENTER ; Entry point for the routine
S:'$D(DTIME) DTIME=300 D HOME^%ZIS
;
;
N IBQUIT,POP,IBDFN,IBCLK,IBDT1,IBDT2,IBNOW
F S IBQUIT=0 D Q:IBQUIT
. S IBDFN=$$ASKPAT() I IBDFN=-1 S IBQUIT=1 Q
. ; Ask about beginning and ending date and perform action
. ; No default valies provided
. D DATE I IBDT1<0 Q S IBQUIT=1 Q ;Enter date range (defaults are begin/end of the clock)
. D ASKDEV
Q
;
ASKDEV ; Ask about output device and print the report (or run task)
N %ZIS
S %ZIS="QM"
W ! D ^%ZIS Q:POP ; Quit and ask for patient again. Otherwise Set IBSTOP=1
; If it was queued
I $D(IO("Q")) D RUNTASK Q
U IO D REPORT^IBUCSP1 ; Generate report directly
D ^%ZISC ; Close the device
Q
;
;
RUNTASK ; Start Taskman job
N ZTRTN,ZTSK,IBVAR,ZTSAVE,ZTDESC
S ZTRTN="REPORT^IBAECP1",ZTDESC="LTC SINGLE PATIENT BILLING PROFILE"
F IBVAR="IBDFN","IBCLK","IBDT1","IBDT2" S ZTSAVE(IBVAR)=""
D ^%ZTLOAD
K IO("Q")
D HOME^%ZIS W !
Q
;
DATE N %DT,Y,IBDT,IBNOW
DATAGN ;Loop entry point
S IBNOW=$$NOW^IBUCMM
S (IBDT1,IBDT2)=-1
; Get beginning date
S IBDT1=$$ASKDT("Start YEAR: ",2019)
I IBDT1<1 Q
; Get ending date
I '$G(IBDT) S IBDT=IBNOW
E I $G(IBDT)>IBNOW S IBDT=IBNOW
S IBDT2=$$ASKDT("Go to YEAR: ",IBDT1)
I IBDT2<1 S IBDT1=-1 Q
I IBDT2<IBDT1 W !,"Ending date must follow start date!",! G DATAGN
Q
;
ASKDT(IBPRMT,IBDFLT) ;Date input
N DIR,Y,X,DIROUT,DIRUT
I $G(IBPRMT)'="" S DIR("A")=IBPRMT
S DIR("B")=IBDFLT
S DIR(0)="F^4:4:K:X'?4N X"
D ^DIR I $D(DIRUT) Q -1
W " ",Y
Q Y
;
;Enter PATIENT NAME
;Customized dialog (added more explanation on '??' input)
ASKPAT() N DIR,DIC,Y,X,IBDFN
F D Q:$D(DIRUT) Q:Y>0
. S DIR("A")="Select PATIENT NAME"
. S DIR(0)="FO"
. S DIR("?")="Enter '??' to list all LTC Patients"
. S DIR("?",1)="Enter a name of LTC Patient"
. S DIR("?",2)="Answer with PATIENT NAME, or SOCIAL SECURITY NUMBER, or last 4 digits"
. S DIR("?",3)="of SOCIAL SECURITY NUMBER, or first initial of last name with last"
. S DIR("?",4)="4 digits of SOCIAL SECURITY NUMBER"
. S DIR("?",5)=""
. D ^DIR Q:$D(DIRUT)
. S X=Y
. I X?3N1"-"2N1"-"4N.3A S X=$TR(X,"-","") ; Remove dashes from SSN
. S DIC="^DPT(",DIC(0)="QME"
. N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
. D ^DIC Q:Y<1 ; Patient code
. S Y=+$G(Y)
. ;W " " D WRTPAT(Y)
I $D(DIRUT) Q -1
Q +Y
;
WRTPAT(IBDFN) ; Write patient's data
N IBZ,IBVET,IBSC
S IBZ=$G(^DPT(IBDFN,0)) Q:IBZ="" ""
S IBSC=($P($G(^DPT(IBDFN,3)),U)="Y")
S IBVET=($P($G(^DPT(IBDFN,"VET")),U)="Y")
W $P(IBZ,U)
W " ",?30,$$FMTE^XLFDT($P($P(IBZ,U,3),"."),"5MZ")
W " ",?42,$$SSN($$EXTERNAL^DILFD(2,.09,"",$P(IBZ,U,9)))
W " ",?55,$S(IBVET:$S(IBSC:"S/C",1:"NSC")_" VETERAN",1:"")
W " ",?68,$$FMTE^XLFDT($P($O(^IBA(351.81,"AE",IBDFN,""),-1),"."),"5MZ")
Q
;
SSN(IBN) ;Format SSN Value
I $L(+IBN)<7 Q IBN
Q $E(IBN,1,3)_"-"_$E(IBN,4,5)_"-"_$E(IBN,6,255)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBUCSP 3145 printed Apr 09, 2024@21:11:34 Page 2
IBUCSP ;WOIFO/AAT-URGENT CARE SINGLE PATIENT PROFILE ; 20-FEB-02
+1 ;;2.0;INTEGRATED BILLING;**663,671**;21-MAR-94;Build 13
+2 ;; Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
ENTER ; Entry point for the routine
+1 if '$DATA(DTIME)
SET DTIME=300
DO HOME^%ZIS
+2 ;
+3 ;
+4 NEW IBQUIT,POP,IBDFN,IBCLK,IBDT1,IBDT2,IBNOW
+5 FOR
SET IBQUIT=0
Begin DoDot:1
+6 SET IBDFN=$$ASKPAT()
IF IBDFN=-1
SET IBQUIT=1
QUIT
+7 ; Ask about beginning and ending date and perform action
+8 ; No default valies provided
+9 ;Enter date range (defaults are begin/end of the clock)
DO DATE
IF IBDT1<0
QUIT
SET IBQUIT=1
QUIT
+10 DO ASKDEV
End DoDot:1
if IBQUIT
QUIT
+11 QUIT
+12 ;
ASKDEV ; Ask about output device and print the report (or run task)
+1 NEW %ZIS
+2 SET %ZIS="QM"
+3 ; Quit and ask for patient again. Otherwise Set IBSTOP=1
WRITE !
DO ^%ZIS
if POP
QUIT
+4 ; If it was queued
+5 IF $DATA(IO("Q"))
DO RUNTASK
QUIT
+6 ; Generate report directly
USE IO
DO REPORT^IBUCSP1
+7 ; Close the device
DO ^%ZISC
+8 QUIT
+9 ;
+10 ;
RUNTASK ; Start Taskman job
+1 NEW ZTRTN,ZTSK,IBVAR,ZTSAVE,ZTDESC
+2 SET ZTRTN="REPORT^IBAECP1"
SET ZTDESC="LTC SINGLE PATIENT BILLING PROFILE"
+3 FOR IBVAR="IBDFN","IBCLK","IBDT1","IBDT2"
SET ZTSAVE(IBVAR)=""
+4 DO ^%ZTLOAD
+5 KILL IO("Q")
+6 DO HOME^%ZIS
WRITE !
+7 QUIT
+8 ;
DATE NEW %DT,Y,IBDT,IBNOW
DATAGN ;Loop entry point
+1 SET IBNOW=$$NOW^IBUCMM
+2 SET (IBDT1,IBDT2)=-1
+3 ; Get beginning date
+4 SET IBDT1=$$ASKDT("Start YEAR: ",2019)
+5 IF IBDT1<1
QUIT
+6 ; Get ending date
+7 IF '$GET(IBDT)
SET IBDT=IBNOW
+8 IF '$TEST
IF $GET(IBDT)>IBNOW
SET IBDT=IBNOW
+9 SET IBDT2=$$ASKDT("Go to YEAR: ",IBDT1)
+10 IF IBDT2<1
SET IBDT1=-1
QUIT
+11 IF IBDT2<IBDT1
WRITE !,"Ending date must follow start date!",!
GOTO DATAGN
+12 QUIT
+13 ;
ASKDT(IBPRMT,IBDFLT) ;Date input
+1 NEW DIR,Y,X,DIROUT,DIRUT
+2 IF $GET(IBPRMT)'=""
SET DIR("A")=IBPRMT
+3 SET DIR("B")=IBDFLT
+4 SET DIR(0)="F^4:4:K:X'?4N X"
+5 DO ^DIR
IF $DATA(DIRUT)
QUIT -1
+6 WRITE " ",Y
+7 QUIT Y
+8 ;
+9 ;Enter PATIENT NAME
+10 ;Customized dialog (added more explanation on '??' input)
ASKPAT() NEW DIR,DIC,Y,X,IBDFN
+1 FOR
Begin DoDot:1
+2 SET DIR("A")="Select PATIENT NAME"
+3 SET DIR(0)="FO"
+4 SET DIR("?")="Enter '??' to list all LTC Patients"
+5 SET DIR("?",1)="Enter a name of LTC Patient"
+6 SET DIR("?",2)="Answer with PATIENT NAME, or SOCIAL SECURITY NUMBER, or last 4 digits"
+7 SET DIR("?",3)="of SOCIAL SECURITY NUMBER, or first initial of last name with last"
+8 SET DIR("?",4)="4 digits of SOCIAL SECURITY NUMBER"
+9 SET DIR("?",5)=""
+10 DO ^DIR
if $DATA(DIRUT)
QUIT
+11 SET X=Y
+12 ; Remove dashes from SSN
IF X?3N1"-"2N1"-"4N.3A
SET X=$TRANSLATE(X,"-","")
+13 SET DIC="^DPT("
SET DIC(0)="QME"
+14 ;Suppress PATIENT file fuzzy lookups
NEW DPTNOFZY
SET DPTNOFZY=1
+15 ; Patient code
DO ^DIC
if Y<1
QUIT
+16 SET Y=+$GET(Y)
+17 ;W " " D WRTPAT(Y)
End DoDot:1
if $DATA(DIRUT)
QUIT
if Y>0
QUIT
+18 IF $DATA(DIRUT)
QUIT -1
+19 QUIT +Y
+20 ;
WRTPAT(IBDFN) ; Write patient's data
+1 NEW IBZ,IBVET,IBSC
+2 SET IBZ=$GET(^DPT(IBDFN,0))
if IBZ=""
QUIT ""
+3 SET IBSC=($PIECE($GET(^DPT(IBDFN,3)),U)="Y")
+4 SET IBVET=($PIECE($GET(^DPT(IBDFN,"VET")),U)="Y")
+5 WRITE $PIECE(IBZ,U)
+6 WRITE " ",?30,$$FMTE^XLFDT($PIECE($PIECE(IBZ,U,3),"."),"5MZ")
+7 WRITE " ",?42,$$SSN($$EXTERNAL^DILFD(2,.09,"",$PIECE(IBZ,U,9)))
+8 WRITE " ",?55,$SELECT(IBVET:$SELECT(IBSC:"S/C",1:"NSC")_" VETERAN",1:"")
+9 WRITE " ",?68,$$FMTE^XLFDT($PIECE($ORDER(^IBA(351.81,"AE",IBDFN,""),-1),"."),"5MZ")
+10 QUIT
+11 ;
SSN(IBN) ;Format SSN Value
+1 IF $LENGTH(+IBN)<7
QUIT IBN
+2 QUIT $EXTRACT(IBN,1,3)_"-"_$EXTRACT(IBN,4,5)_"-"_$EXTRACT(IBN,6,255)
