BARRTRAN.m

BARRTRAN ; IHS/SD/LSL - BATCH POSTED PAYMENTS REPORT ;

 ;;1.8;IHS ACCOUNTS RECEIVABLE;*24*;OCT 26, 2005;Build 69

 ; IHS/SD/POTT HEAT133069 BAR*1.8*24

 ; IHS/SD/POTT HEAT124730 ADDING DOS TO REPORT BAR*1.8*24

START ; EP

 ; Collections report using FM print

 ;

LOOKUP ;

 ; Collection Register name lookup

 K DUOUT,DTOUT,BAREFLG

 S DIC="90051.01"

 S DIC(0)="AEMQZ"

 D ^DIC

 K DIC

 S:Y<0 BAREFLG=1

 S:$D(DUOUT) BAREFLG=1

 S:$D(DTOUT) BAREFLG=1

 I $D(BAREFLG) Q

 I Y>0 D

 . S BARBATCH=+Y

 . S BARBEX=$P(Y(0),U)

 G:$D(BAREFLG) END

 ;

DIPVAR ;

 ; Set up DIP variables and Header routine

 S BAR("SITE")=$P(^DIC(4,DUZ(2),0),U)

 S DIC="90050.03"

 S L=0

 ;S FLDS="15;W3;N;""IT"",4;L15;N,&3.5;""PMT"",NUMDATE4(#12);""DT"",4:3;L15;""BILLED TO"",602;L15;""SESSION"",601;C10;""UFMS EXPORT FILE"""  ;Y2000

 S FLDS="15;W3;N;""IT"",4;L15;N,&3.5;""PMT"",NUMDATE4(#12);""DT / DOS"",4:3;L15;""BILLED TO"",4:101;L15;""PATIENT"""  ;Y2000

 S BY="@14,+15;S1,6,4,@101"

 S DHIT="W ?34,$$GETDOS^BARRTRAN(DITTO(2))" ;P.OTT HEAT#124730 BAR*1.8*24

 ;A string of M code which will be executed for every entry after all the fields specified in FLDS have been printed. 

 S FR=BARBEX_",,,,PAYMENT"

 S TO=BARBEX_",,,,PAYMENT"

 ;

PRINT ;

 ; Print

 ; GET DEVICE (QUEUEING ALLOWED)

 S Y=$$DIR^XBDIR("S^P:PRINT Output;B:BROWSE Output on Screen","Do you wish to ","P","","","",1)

 K DA

 Q:$D(DIRUT)

 S DHD=BARBEX_"POSTINGS ***CONFIDENTIAL PATIENT INFORMATION***"

 I Y="B" D  Q

 . S XBFLD("BROWSE")=1

 . S BARIOSL=IOSL

 . S IOSL=600

 . D VIEWD^XBLM("EN1^DIP")

 . D FULL^VALM1

 . W $$EN^BARVDF("IOF")

 .D CLEAR^VALM1 ;clears out all list man stuff

 .K XQORNEST,VALMKEY,VALM,VALMAR,VALMBCK,VALMBG,VALMCAP,VALMCNT

 .K VALMOFF,VALMCON,VALMDN,VALMEVL,VALMIOXY,VALMKEY,VALMLFT,VALMLST

 .K VALMMENU,VALMSGR,VALMUP,VALMWD,VALMY,XQORS,XQORSPEW,VALMCOFF

DEVE .;

 .S IOSL=BARIOSL

 .K BARIOSL

 D EN1^DIP

 ;

DSP ; EP for VALM

 D ^%ZISC,HOME^%ZIS

 D EOP^BARUTL(1)

 ;

END ;

 Q

GETDOS(BARBILL) ;HEAT#124730

 NEW X

 S X=$$GET1^DIQ(90050.01,BARBILL,102,"I")

 Q $$SDT^BARDUTL(X)

 ;---EOR 

BARRTRAN  ; IHS/SD/LSL - BATCH POSTED PAYMENTS REPORT ;

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;*24*;OCT 26, 2005;Build 69

 +2       ; IHS/SD/POTT HEAT133069 BAR*1.8*24

 +3       ; IHS/SD/POTT HEAT124730 ADDING DOS TO REPORT BAR*1.8*24

START     ; EP

 +1       ; Collections report using FM print

 +2       ;

LOOKUP    ;

 +1       ; Collection Register name lookup

 +2        KILL DUOUT,DTOUT,BAREFLG

 +3        SET DIC="90051.01"

 +4        SET DIC(0)="AEMQZ"

 +5        DO ^DIC

 +6        KILL DIC

 +7        IF Y<0

               SET BAREFLG=1

 +8        IF $DATA(DUOUT)

               SET BAREFLG=1

 +9        IF $DATA(DTOUT)

               SET BAREFLG=1

 +10       IF $DATA(BAREFLG)

               QUIT 

 +11       IF Y>0

               Begin DoDot:1

 +12               SET BARBATCH=+Y

 +13               SET BARBEX=$PIECE(Y(0),U)

               End DoDot:1

 +14       IF $DATA(BAREFLG)

               GOTO END

 +15      ;

DIPVAR    ;

 +1       ; Set up DIP variables and Header routine

 +2        SET BAR("SITE")=$PIECE(^DIC(4,DUZ(2),0),U)

 +3        SET DIC="90050.03"

 +4        SET L=0

 +5       ;S FLDS="15;W3;N;""IT"",4;L15;N,&3.5;""PMT"",NUMDATE4(#12);""DT"",4:3;L15;""BILLED TO"",602;L15;""SESSION"",601;C10;""UFMS EXPORT FILE"""  ;Y2000

 +6       ;Y2000

           SET FLDS="15;W3;N;""IT"",4;L15;N,&3.5;""PMT"",NUMDATE4(#12);""DT / DOS"",4:3;L15;""BILLED TO"",4:101;L15;""PATIENT"""

 +7        SET BY="@14,+15;S1,6,4,@101"

 +8       ;P.OTT HEAT#124730 BAR*1.8*24

           SET DHIT="W ?34,$$GETDOS^BARRTRAN(DITTO(2))"

 +9       ;A string of M code which will be executed for every entry after all the fields specified in FLDS have been printed. 

 +10       SET FR=BARBEX_",,,,PAYMENT"

 +11       SET TO=BARBEX_",,,,PAYMENT"

 +12      ;

PRINT     ;

 +1       ; Print

 +2       ; GET DEVICE (QUEUEING ALLOWED)

 +3        SET Y=$$DIR^XBDIR("S^P:PRINT Output;B:BROWSE Output on Screen","Do you wish to ","P","","","",1)

 +4        KILL DA

 +5        IF $DATA(DIRUT)

               QUIT 

 +6        SET DHD=BARBEX_"POSTINGS ***CONFIDENTIAL PATIENT INFORMATION***"

 +7        IF Y="B"

               Begin DoDot:1

 +8                SET XBFLD("BROWSE")=1

 +9                SET BARIOSL=IOSL

 +10               SET IOSL=600

 +11               DO VIEWD^XBLM("EN1^DIP")

 +12               DO FULL^VALM1

 +13               WRITE $$EN^BARVDF("IOF")

 +14      ;clears out all list man stuff

                   DO CLEAR^VALM1

 +15               KILL XQORNEST,VALMKEY,VALM,VALMAR,VALMBCK,VALMBG,VALMCAP,VALMCNT

 +16               KILL VALMOFF,VALMCON,VALMDN,VALMEVL,VALMIOXY,VALMKEY,VALMLFT,VALMLST

 +17               KILL VALMMENU,VALMSGR,VALMUP,VALMWD,VALMY,XQORS,XQORSPEW,VALMCOFF

DEVE      ;

 +1                SET IOSL=BARIOSL

 +2                KILL BARIOSL

               End DoDot:1

               QUIT 

 +3        DO EN1^DIP

 +4       ;

DSP       ; EP for VALM

 +1        DO ^%ZISC

           DO HOME^%ZIS

 +2        DO EOP^BARUTL(1)

 +3       ;

END       ;

 +1        QUIT 

GETDOS(BARBILL) ;HEAT#124730

 +1        NEW X

 +2        SET X=$$GET1^DIQ(90050.01,BARBILL,102,"I")

 +3        QUIT $$SDT^BARDUTL(X)

 +4       ;---EOR