BARBLLK.m

BARBLLK ; IHS/SD/LSL - LOOKUPS INTO THE BILL FILE ;07/10/2010

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**19**;OCT 26, 2005

 ;;

 ; IHS/SD/TMM 06/18/2010 1.8*Patch 19 (M819_5), Add Prepayment functionality.

 ;                       See work order 3PMS10001

 ;                       New tags EN1 and PAT1

 ;                       to pass default values (DIC("B")) during lookup

 ;                       (^BARCLU,^BARCLU01,^BARPUTL,^BARPST1,^BARBLLK)

 ; ********************************************************************* ;

 ;

 ;asks PATIENT and returns BARBL = IEN if found

 ;bill=open & A/R service/section matches users

 K BARBL

 S BARBLDA=0

 D ^XBNEW("PAT^BARBLLK:BARBLDA") ;new environment

 I $G(BARBLDA)>0 S BARBL(.01)=$$VAL^XBDIQ1(90050.01,BARBLDA,.01)

 E  K BARBL

 Q

 ; *********************************************************************

 ;

PAT ;EP lookup bill by patient with open accounts

 S BARPASS=$$EN^BARPST1()

 I BARPASS'["" Q

 S BARCNT=$$EN^BARPNP2(BARPASS)

 I 'BARCNT W !,?10," NO SELECTION ",! Q

 D HIT^BARPNP2(BARPASS)

 K DIR

 S DIR(0)="N^0:"_BARCNT

 S DIR("A")="LINE # or 0 to quit"

 D ^DIR

 I Y'>0 Q

 S BARBLDA=$O(^BARTMP($J,"B",Y,0))

 Q

 ;

 ;--->NEW TAG EN1--->  ;M819*ADD*TMM*20100711 (819_4)

 ; (copied entry to ^BARBLLK but calls PAT1^BARBLLK instead of PAT^BARBLLK

EN1(DICB,DICB2,DICB3) ;

 ;asks PATIENT and returns BARBL = IEN if found

 ;bill=open & A/R service/section matches users

 K BARBL

 S BARBLDA=0

 D ^XBNEW("PAT1^BARBLLK:BARBLDA;DICB;DICB2;DICB3") ;new environment    ;M819*ADD*TMM*20100711 ;use default for looup

 I $G(BARBLDA)>0 S BARBL(.01)=$$VAL^XBDIQ1(90050.01,BARBLDA,.01)

 E  K BARBL

 Q

 ;

PAT1 ;EP lookup bill by patient with open accounts

 ;--->NEW TAG PAT1--->  ;M819*ADD*TMM*20100711 (819_4)

 ; (copied from PAT^BARBLLK passes default DIC("B") values to ^BARPUTL

 ;

 ;M819*DEL*TMM*20100711***  S BARPASS=$$EN^BARPST1()

 S DICB=$G(DICB)

 S DICB2=$G(DICB2)

 S DICB3=$G(DICB3)

 S BARPASS=$$EN1^BARPST1(DICB,DICB2,DICB3)

 I BARPASS'["" Q

 S BARCNT=$$EN^BARPNP2(BARPASS)

 I 'BARCNT W !,?10," NO SELECTION ",! Q

 D HIT^BARPNP2(BARPASS)

 K DIR

 S DIR(0)="N^0:"_BARCNT

 S DIR("A")="LINE # or 0 to quit"

 D ^DIR

 I Y'>0 Q

 S BARBLDA=$O(^BARTMP($J,"B",Y,0))

 Q

BARBLLK   ; IHS/SD/LSL - LOOKUPS INTO THE BILL FILE ;07/10/2010

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**19**;OCT 26, 2005

 +2       ;;

 +3       ; IHS/SD/TMM 06/18/2010 1.8*Patch 19 (M819_5), Add Prepayment functionality.

 +4       ;                       See work order 3PMS10001

 +5       ;                       New tags EN1 and PAT1

 +6       ;                       to pass default values (DIC("B")) during lookup

 +7       ;                       (^BARCLU,^BARCLU01,^BARPUTL,^BARPST1,^BARBLLK)

 +8       ; ********************************************************************* ;

 +9       ;

 +10      ;asks PATIENT and returns BARBL = IEN if found

 +11      ;bill=open & A/R service/section matches users

 +12       KILL BARBL

 +13       SET BARBLDA=0

 +14      ;new environment

           DO ^XBNEW("PAT^BARBLLK:BARBLDA")

 +15       IF $GET(BARBLDA)>0

               SET BARBL(.01)=$$VAL^XBDIQ1(90050.01,BARBLDA,.01)

 +16      IF '$TEST

               KILL BARBL

 +17       QUIT 

 +18      ; *********************************************************************

 +19      ;

PAT       ;EP lookup bill by patient with open accounts

 +1        SET BARPASS=$$EN^BARPST1()

 +2        IF BARPASS'[""

               QUIT 

 +3        SET BARCNT=$$EN^BARPNP2(BARPASS)

 +4        IF 'BARCNT

               WRITE !,?10," NO SELECTION ",!

               QUIT 

 +5        DO HIT^BARPNP2(BARPASS)

 +6        KILL DIR

 +7        SET DIR(0)="N^0:"_BARCNT

 +8        SET DIR("A")="LINE # or 0 to quit"

 +9        DO ^DIR

 +10       IF Y'>0

               QUIT 

 +11       SET BARBLDA=$ORDER(^BARTMP($JOB,"B",Y,0))

 +12       QUIT 

 +13      ;

 +14      ;--->NEW TAG EN1--->  ;M819*ADD*TMM*20100711 (819_4)

 +15      ; (copied entry to ^BARBLLK but calls PAT1^BARBLLK instead of PAT^BARBLLK

EN1(DICB,DICB2,DICB3) ;

 +1       ;asks PATIENT and returns BARBL = IEN if found

 +2       ;bill=open & A/R service/section matches users

 +3        KILL BARBL

 +4        SET BARBLDA=0

 +5       ;new environment    ;M819*ADD*TMM*20100711 ;use default for looup

           DO ^XBNEW("PAT1^BARBLLK:BARBLDA;DICB;DICB2;DICB3")

 +6        IF $GET(BARBLDA)>0

               SET BARBL(.01)=$$VAL^XBDIQ1(90050.01,BARBLDA,.01)

 +7       IF '$TEST

               KILL BARBL

 +8        QUIT 

 +9       ;

PAT1      ;EP lookup bill by patient with open accounts

 +1       ;--->NEW TAG PAT1--->  ;M819*ADD*TMM*20100711 (819_4)

 +2       ; (copied from PAT^BARBLLK passes default DIC("B") values to ^BARPUTL

 +3       ;

 +4       ;M819*DEL*TMM*20100711***  S BARPASS=$$EN^BARPST1()

 +5        SET DICB=$GET(DICB)

 +6        SET DICB2=$GET(DICB2)

 +7        SET DICB3=$GET(DICB3)

 +8        SET BARPASS=$$EN1^BARPST1(DICB,DICB2,DICB3)

 +9        IF BARPASS'[""

               QUIT 

 +10       SET BARCNT=$$EN^BARPNP2(BARPASS)

 +11       IF 'BARCNT

               WRITE !,?10," NO SELECTION ",!

               QUIT 

 +12       DO HIT^BARPNP2(BARPASS)

 +13       KILL DIR

 +14       SET DIR(0)="N^0:"_BARCNT

 +15       SET DIR("A")="LINE # or 0 to quit"

 +16       DO ^DIR

 +17       IF Y'>0

               QUIT 

 +18       SET BARBLDA=$ORDER(^BARTMP($JOB,"B",Y,0))

 +19       QUIT