IBAECP ;WOIFO/AAT-LTC SINGLE PATIENT PROFILE ; 20-FEB-02
;;2.0;INTEGRATED BILLING;**171,176,199**;21-MAR-94
;; Per VHA Directive 10-93-142, this routine should not be modified
;
S:'$D(DTIME) DTIME=300 D HOME^%ZIS
;
;
N IBQUIT,POP
F S IBQUIT=0 D Q:IBQUIT
. N IBDFN,IBCLK,IBDT1,IBDT2,%DT,X,Y,DIC,IBOFD,IBOEV
. W !
. S IBDFN=$$ASKPAT() I IBDFN=-1 S IBQUIT=1 Q
. ; Enter required clock (if more than one)
. S IBCLK=$$ASKCLK(IBDFN) I IBCLK<1 Q S IBQUIT=1
. ; Ask about beginning and ending date and perform action
. ; No default valies provided
. ; W !,"The report is not available at the patch IB*2.0*171" Q
. D DATE I IBDT1<0 Q S IBQUIT=1 Q ;Enter date range (defaults are begin/end of the clock)
. D ASKOFD I IBOFD<0 Q S IBQUIT=1 Q ;Option - print free days
. D ASKOEV I IBOEV<0 Q S IBQUIT=1 Q ;Option - print event history
. 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^IBAECP1 ; 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","IBOFD","IBOEV" S ZTSAVE(IBVAR)=""
D ^%ZTLOAD
K IO("Q")
D HOME^%ZIS W !
Q
;
; User's interface for LTC Billing Clock
; If the user has only one clock - doesn't ask, only shows brief info.
; Parameters:
; IBDFN - patient IEN
; IBSHOW - if 1, the list of clocks will be printed
; Returns: LTC Clock IEN (or -1, if canceled, or 0, if the user doesn't has any clocks)
ASKCLK(IBDFN,IBSHOW) N IBDT,IBDT2,IBX,IBZ,IBCNT,IBCL,DIRUT,Y,DIR,IBI,IBY,IBCLK
I '$D(^IBA(351.81,"AE",IBDFN)) D Q 0 ; No data for the patient
. W !,"The user doesn't have LTC Billing Clock created"
; Collect all data in IBCL array IBCL(DATE)=IEN,IBCL=<Number of clocks>
S IBCL=0
S IBCLK=0,IBDT=0 F S IBDT=$O(^IBA(351.81,"AE",IBDFN,IBDT)) Q:'IBDT D
. S IBX=0 F S IBX=$O(^IBA(351.81,"AE",IBDFN,IBDT,IBX)) Q:'IBX D
.. S IBCL(IBDT)=IBX
.. S IBCL=IBCL+1
;
; If there is only one clock - no need to ask, just show
I IBCL=1 S IBCLK=IBCL($O(IBCL(""))) D LSTCLK W ! Q IBCLK
K Y
F D Q:$D(DIRUT) Q:$D(IBCL(Y)) W " ??"
. ;Choose one
. I $D(Y)!($G(IBSHOW)) W ! D LSTCLK W ! ; Bad enter - list options
. K DIR,DIRUT
. S DIR(0)="FE"
. S DIR("A")="Choose LTC BILLING CLOCK (1-"_IBCL_")"
. S DIR("B")=$$FMTE^XLFDT(+$O(IBCL(""),-1),"1D")
. S DIR("?")="Enter date of the required LTC BILLING CLOCK. Enter '??' for clocks list."
. S DIR("??")="^D LSTCLK^IBAECP"
. D ^DIR Q:$D(DIRUT)
. ; User may enter just number
. I Y=+Y,Y>0,Y'>IBCL D I IBY S Y=IBY Q
.. S IBY="" F IBI=1:1:Y S IBY=$O(IBCL(IBY)) Q:IBY=""
. S %DT="" D ^%DT ; Convert external to internal format
I $D(DIRUT) Q -1
W " (",$$FMTE^XLFDT(Y),")"
Q IBCL(Y)
;
; Ask begin/end dates, with default values
; Input: IBCLK - LTC Clock IEN
; Output: IBDT1,IBDT2 - begin/end dates
DATE N %DT,Y,IBDT,IBNOW
DATAGN ;Loop entry point
S (IBDT1,IBDT2)=-1
; Get beginning date
S IBDT=$P($G(^IBA(351.81,IBCLK,0)),U,3)
S IBDT1=$$ASKDT("Start with DATE: ",IBDT)
I IBDT1<1 Q
; Get ending date
S IBDT=$P($G(^IBA(351.81,IBCLK,0)),U,4)
S IBNOW=$$NOW()
I 'IBDT S IBDT=IBNOW
E I IBDT>IBNOW S IBDT=IBNOW
S IBDT2=$$ASKDT("Go to DATE: ",IBDT)
I IBDT2<1 S IBDT1=-1 Q
I IBDT2<IBDT1 W !,"Ending date must follow start date!",! G DATAGN
Q
;
;Returns today's date in FM format
NOW() N %,%H,%I,X
D NOW^%DTC
Q X
;
; Ask - print free days or not?
; Input: none
; Output: IBOFD (bool) IBOFD=-1 if cancelled
ASKOFD ; Default - YES
N DIR,Y,DUOUT
S DIR(0)="Y",DIR("A")="Include DAYS NOT SUBJECT TO LTC COPAY on this report",DIR("B")="YES"
D ^DIR
S IBOFD=$S($G(DUOUT)!$G(DUOUT)!(Y="^"):-1,1:Y)
Q
; Ask - print LTC events or not?
; Input: none
; Output: IBOEV (bool) IBOEV=-1 if cancelled
ASKOEV ; Default - YES
N DIR,Y,DUOUT
S DIR(0)="Y",DIR("A")="Include LTC EVENTS on this report",DIR("B")="YES"
D ^DIR
S IBOEV=$S($G(DUOUT)!$G(DTOUT)!(Y="^"):-1,1:Y)
Q
; Double question mark action - for the "enter clock" dialog
; Input:
; IBCL=<Number of clocks>
; IBCL(<Clock date>)=<Clock IEN> local array - list of clocks
; IBDFN= IEN of the patient
LSTCLK N IBZ,IBDT,IBCNT,IBDT2
W !,$P(^DPT(IBDFN,0),U)," has the following LTC Copay Clock",$S(IBCL>1:"s",1:""),!
S IBCNT=0
S IBDT=0 F S IBDT=$O(IBCL(IBDT)) Q:'IBDT D
. S IBX=IBCL(IBDT)
. S IBZ=^IBA(351.81,IBX,0),IBCNT=IBCNT+1
. W !?10,IBCNT,?15,$$FMTE^XLFDT(IBDT)
. S IBDT2=$P(IBZ,U,4)
. I IBDT2 W ?28," - ",$$FMTE^XLFDT(IBDT2)
. W ?48,$$EXTERNAL^DILFD(351.81,.05,"",$P(IBZ,"^",5))
Q
;
; Input: prompt, default value (FM format)
; Output: date (FM) or -1, if cancelled
ASKDT(IBPRMT,IBDFLT) ;Date input
N DIR,Y,Y0,X,DIROUT,DIRUT
I $G(IBPRMT)'="" S DIR("A")=IBPRMT
I $G(IBDFLT)'="" S DIR("B")=$$FMTE^XLFDT(IBDFLT,"1D")
S DIR(0)="DA"
D ^DIR I $D(DIRUT) Q -1
W " (",$$FMTE^XLFDT(Y),")"
Q Y
;
;Enter PATIENT NAME (LTC Patients, having a clock only!)
;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)=""
. S DIR("??")="^D ASKPATQQ^IBAECP"
. 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"
. S DIC("S")="I $D(^IBA(351.81,""AE"",Y))"
. S DIC("W")="D WRTPAT^IBAECP(+Y)"
. 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
;
ASKPATQQ N DIC,X,Y,IBDFN,IBI,DIR,DIRUT,DIROUT,DTOUT,DUOUT,IBCNT
D ASKPHD
S IBI=7,IBCNT=0
;S DIC="^DPT",DIC(0)="F",X="??" D ^DIC
S IBDFN=0 F S IBDFN=$O(^IBA(351.81,"AE",IBDFN)) Q:'IBDFN D Q:$D(DIRUT)
. W ! S IBI=IBI+1
. I IBI>IOSL S DIR(0)="E" D ^DIR W ! Q:$D(DIRUT) W ! S IBI=3 ; D ASKPHD S IBI=4
. ; S IBCNT=IBCNT+1
. ; W $J(IBCNT,4)," ",?6
. D WRTPAT(IBDFN)
Q
;
ASKPHD ;Header
N IBI
W !,"Choose an LTC Patient:",!
Q
;W !," LTC PATIENT NAME",?30,"BIRTH DATE",?45,"SSN",?55,"STATUS",?68,"CLK DATE"
;W ! F IBI=1:1:80 W "-"
;Q
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[HIBAECP 7322 printed Apr 09, 2024@21:28:13 Page 2
IBAECP ;WOIFO/AAT-LTC SINGLE PATIENT PROFILE ; 20-FEB-02
+1 ;;2.0;INTEGRATED BILLING;**171,176,199**;21-MAR-94
+2 ;; Per VHA Directive 10-93-142, this routine should not be modified
+3 ;
+4 if '$DATA(DTIME)
SET DTIME=300
DO HOME^%ZIS
+5 ;
+6 ;
+7 NEW IBQUIT,POP
+8 FOR
SET IBQUIT=0
Begin DoDot:1
+9 NEW IBDFN,IBCLK,IBDT1,IBDT2,%DT,X,Y,DIC,IBOFD,IBOEV
+10 WRITE !
+11 SET IBDFN=$$ASKPAT()
IF IBDFN=-1
SET IBQUIT=1
QUIT
+12 ; Enter required clock (if more than one)
+13 SET IBCLK=$$ASKCLK(IBDFN)
IF IBCLK<1
QUIT
SET IBQUIT=1
+14 ; Ask about beginning and ending date and perform action
+15 ; No default valies provided
+16 ; W !,"The report is not available at the patch IB*2.0*171" Q
+17 ;Enter date range (defaults are begin/end of the clock)
DO DATE
IF IBDT1<0
QUIT
SET IBQUIT=1
QUIT
+18 ;Option - print free days
DO ASKOFD
IF IBOFD<0
QUIT
SET IBQUIT=1
QUIT
+19 ;Option - print event history
DO ASKOEV
IF IBOEV<0
QUIT
SET IBQUIT=1
QUIT
+20 DO ASKDEV
End DoDot:1
if IBQUIT
QUIT
+21 QUIT
+22 ;
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^IBAECP1
+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","IBOFD","IBOEV"
SET ZTSAVE(IBVAR)=""
+4 DO ^%ZTLOAD
+5 KILL IO("Q")
+6 DO HOME^%ZIS
WRITE !
+7 QUIT
+8 ;
+9 ; User's interface for LTC Billing Clock
+10 ; If the user has only one clock - doesn't ask, only shows brief info.
+11 ; Parameters:
+12 ; IBDFN - patient IEN
+13 ; IBSHOW - if 1, the list of clocks will be printed
+14 ; Returns: LTC Clock IEN (or -1, if canceled, or 0, if the user doesn't has any clocks)
ASKCLK(IBDFN,IBSHOW) NEW IBDT,IBDT2,IBX,IBZ,IBCNT,IBCL,DIRUT,Y,DIR,IBI,IBY,IBCLK
+1 ; No data for the patient
IF '$DATA(^IBA(351.81,"AE",IBDFN))
Begin DoDot:1
+2 WRITE !,"The user doesn't have LTC Billing Clock created"
End DoDot:1
QUIT 0
+3 ; Collect all data in IBCL array IBCL(DATE)=IEN,IBCL=<Number of clocks>
+4 SET IBCL=0
+5 SET IBCLK=0
SET IBDT=0
FOR
SET IBDT=$ORDER(^IBA(351.81,"AE",IBDFN,IBDT))
if 'IBDT
QUIT
Begin DoDot:1
+6 SET IBX=0
FOR
SET IBX=$ORDER(^IBA(351.81,"AE",IBDFN,IBDT,IBX))
if 'IBX
QUIT
Begin DoDot:2
+7 SET IBCL(IBDT)=IBX
+8 SET IBCL=IBCL+1
End DoDot:2
End DoDot:1
+9 ;
+10 ; If there is only one clock - no need to ask, just show
+11 IF IBCL=1
SET IBCLK=IBCL($ORDER(IBCL("")))
DO LSTCLK
WRITE !
QUIT IBCLK
+12 KILL Y
+13 FOR
Begin DoDot:1
+14 ;Choose one
+15 ; Bad enter - list options
IF $DATA(Y)!($GET(IBSHOW))
WRITE !
DO LSTCLK
WRITE !
+16 KILL DIR,DIRUT
+17 SET DIR(0)="FE"
+18 SET DIR("A")="Choose LTC BILLING CLOCK (1-"_IBCL_")"
+19 SET DIR("B")=$$FMTE^XLFDT(+$ORDER(IBCL(""),-1),"1D")
+20 SET DIR("?")="Enter date of the required LTC BILLING CLOCK. Enter '??' for clocks list."
+21 SET DIR("??")="^D LSTCLK^IBAECP"
+22 DO ^DIR
if $DATA(DIRUT)
QUIT
+23 ; User may enter just number
+24 IF Y=+Y
IF Y>0
IF Y'>IBCL
Begin DoDot:2
+25 SET IBY=""
FOR IBI=1:1:Y
SET IBY=$ORDER(IBCL(IBY))
if IBY=""
QUIT
End DoDot:2
IF IBY
SET Y=IBY
QUIT
+26 ; Convert external to internal format
SET %DT=""
DO ^%DT
End DoDot:1
if $DATA(DIRUT)
QUIT
if $DATA(IBCL(Y))
QUIT
WRITE " ??"
+27 IF $DATA(DIRUT)
QUIT -1
+28 WRITE " (",$$FMTE^XLFDT(Y),")"
+29 QUIT IBCL(Y)
+30 ;
+31 ; Ask begin/end dates, with default values
+32 ; Input: IBCLK - LTC Clock IEN
+33 ; Output: IBDT1,IBDT2 - begin/end dates
DATE NEW %DT,Y,IBDT,IBNOW
DATAGN ;Loop entry point
+1 SET (IBDT1,IBDT2)=-1
+2 ; Get beginning date
+3 SET IBDT=$PIECE($GET(^IBA(351.81,IBCLK,0)),U,3)
+4 SET IBDT1=$$ASKDT("Start with DATE: ",IBDT)
+5 IF IBDT1<1
QUIT
+6 ; Get ending date
+7 SET IBDT=$PIECE($GET(^IBA(351.81,IBCLK,0)),U,4)
+8 SET IBNOW=$$NOW()
+9 IF 'IBDT
SET IBDT=IBNOW
+10 IF '$TEST
IF IBDT>IBNOW
SET IBDT=IBNOW
+11 SET IBDT2=$$ASKDT("Go to DATE: ",IBDT)
+12 IF IBDT2<1
SET IBDT1=-1
QUIT
+13 IF IBDT2<IBDT1
WRITE !,"Ending date must follow start date!",!
GOTO DATAGN
+14 QUIT
+15 ;
+16 ;Returns today's date in FM format
NOW() NEW %,%H,%I,X
+1 DO NOW^%DTC
+2 QUIT X
+3 ;
+4 ; Ask - print free days or not?
+5 ; Input: none
+6 ; Output: IBOFD (bool) IBOFD=-1 if cancelled
ASKOFD ; Default - YES
+1 NEW DIR,Y,DUOUT
+2 SET DIR(0)="Y"
SET DIR("A")="Include DAYS NOT SUBJECT TO LTC COPAY on this report"
SET DIR("B")="YES"
+3 DO ^DIR
+4 SET IBOFD=$SELECT($GET(DUOUT)!$GET(DUOUT)!(Y="^"):-1,1:Y)
+5 QUIT
+6 ; Ask - print LTC events or not?
+7 ; Input: none
+8 ; Output: IBOEV (bool) IBOEV=-1 if cancelled
ASKOEV ; Default - YES
+1 NEW DIR,Y,DUOUT
+2 SET DIR(0)="Y"
SET DIR("A")="Include LTC EVENTS on this report"
SET DIR("B")="YES"
+3 DO ^DIR
+4 SET IBOEV=$SELECT($GET(DUOUT)!$GET(DTOUT)!(Y="^"):-1,1:Y)
+5 QUIT
+6 ; Double question mark action - for the "enter clock" dialog
+7 ; Input:
+8 ; IBCL=<Number of clocks>
+9 ; IBCL(<Clock date>)=<Clock IEN> local array - list of clocks
+10 ; IBDFN= IEN of the patient
LSTCLK NEW IBZ,IBDT,IBCNT,IBDT2
+1 WRITE !,$PIECE(^DPT(IBDFN,0),U)," has the following LTC Copay Clock",$SELECT(IBCL>1:"s",1:""),!
+2 SET IBCNT=0
+3 SET IBDT=0
FOR
SET IBDT=$ORDER(IBCL(IBDT))
if 'IBDT
QUIT
Begin DoDot:1
+4 SET IBX=IBCL(IBDT)
+5 SET IBZ=^IBA(351.81,IBX,0)
SET IBCNT=IBCNT+1
+6 WRITE !?10,IBCNT,?15,$$FMTE^XLFDT(IBDT)
+7 SET IBDT2=$PIECE(IBZ,U,4)
+8 IF IBDT2
WRITE ?28," - ",$$FMTE^XLFDT(IBDT2)
+9 WRITE ?48,$$EXTERNAL^DILFD(351.81,.05,"",$PIECE(IBZ,"^",5))
End DoDot:1
+10 QUIT
+11 ;
+12 ; Input: prompt, default value (FM format)
+13 ; Output: date (FM) or -1, if cancelled
ASKDT(IBPRMT,IBDFLT) ;Date input
+1 NEW DIR,Y,Y0,X,DIROUT,DIRUT
+2 IF $GET(IBPRMT)'=""
SET DIR("A")=IBPRMT
+3 IF $GET(IBDFLT)'=""
SET DIR("B")=$$FMTE^XLFDT(IBDFLT,"1D")
+4 SET DIR(0)="DA"
+5 DO ^DIR
IF $DATA(DIRUT)
QUIT -1
+6 WRITE " (",$$FMTE^XLFDT(Y),")"
+7 QUIT Y
+8 ;
+9 ;Enter PATIENT NAME (LTC Patients, having a clock only!)
+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 SET DIR("??")="^D ASKPATQQ^IBAECP"
+11 DO ^DIR
if $DATA(DIRUT)
QUIT
+12 SET X=Y
+13 ; Remove dashes from SSN
IF X?3N1"-"2N1"-"4N.3A
SET X=$TRANSLATE(X,"-","")
+14 SET DIC="^DPT("
SET DIC(0)="QME"
+15 SET DIC("S")="I $D(^IBA(351.81,""AE"",Y))"
+16 SET DIC("W")="D WRTPAT^IBAECP(+Y)"
+17 ;Suppress PATIENT file fuzzy lookups
NEW DPTNOFZY
SET DPTNOFZY=1
+18 ; Patient code
DO ^DIC
if Y<1
QUIT
+19 SET Y=+$GET(Y)
+20 ;W " " D WRTPAT(Y)
End DoDot:1
if $DATA(DIRUT)
QUIT
if Y>0
QUIT
+21 IF $DATA(DIRUT)
QUIT -1
+22 QUIT +Y
+23 ;
ASKPATQQ NEW DIC,X,Y,IBDFN,IBI,DIR,DIRUT,DIROUT,DTOUT,DUOUT,IBCNT
+1 DO ASKPHD
+2 SET IBI=7
SET IBCNT=0
+3 ;S DIC="^DPT",DIC(0)="F",X="??" D ^DIC
+4 SET IBDFN=0
FOR
SET IBDFN=$ORDER(^IBA(351.81,"AE",IBDFN))
if 'IBDFN
QUIT
Begin DoDot:1
+5 WRITE !
SET IBI=IBI+1
+6 ; D ASKPHD S IBI=4
IF IBI>IOSL
SET DIR(0)="E"
DO ^DIR
WRITE !
if $DATA(DIRUT)
QUIT
WRITE !
SET IBI=3
+7 ; S IBCNT=IBCNT+1
+8 ; W $J(IBCNT,4)," ",?6
+9 DO WRTPAT(IBDFN)
End DoDot:1
if $DATA(DIRUT)
QUIT
+10 QUIT
+11 ;
ASKPHD ;Header
+1 NEW IBI
+2 WRITE !,"Choose an LTC Patient:",!
+3 QUIT
+4 ;W !," LTC PATIENT NAME",?30,"BIRTH DATE",?45,"SSN",?55,"STATUS",?68,"CLK DATE"
+5 ;W ! F IBI=1:1:80 W "-"
+6 ;Q
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)
