IBUCSP.m

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 ---IBUCSP   3145     printed  Mar 13, 2025@21:34:21                                                                                                                                                                                                      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)