BARUFLTR ; IHS/SD/TPF - UFMS LETTERS ;
;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,17**;OCT 22, 2008
Q
;
;LETTER(BARAMT,BARCOL,BARCHK,BARSCHED,BARINS,BARLTR) ;EP - PRINT LETTER
LETTER(BARAMT,BARCOL,BARCHK,BARSCHED,BARINS,BARLTR,BARRETYP,BARADJT) ;EP - PRINT LETTER ;BAR*1.8*4
S BARSAVE=1
LETTER1 ;EP -
S Y=DT X ^DD("DD")
S BAREXNOW=Y
;S BARDUZ=DUZ
;S BARDUZ2=DUZ(2)
S:'$G(BARDUZ) BARDUZ=DUZ ;BAR*1.8*4 IF THESE ARE SET THE CALL IF FROM THE REPRINT OPTION
S:'$G(BARDUZ2) BARDUZ2=DUZ(2)
W !!,"Select device to print Finance letter..."
S %ZIS("B")=""
S %ZIS="MQO"
D ^%ZIS
Q:POP
;I IO=IO(0) W !!,"CAN'T PRINT LETTER TO THE SCREEN!!" H 2 G LETTER1 ;BAR*1.8*4 SCR56
I $D(IO("Q")) D QUE Q
U IO
D PRINT
W @IOF
D ^%ZISC
Q
QUE ; EP - QUE 'NOT SENT' OR 'DELAY SEND' REPORT
S ZTRTN="PRINT^BARUFLTR"
S ZTDESC=BARLTR
S ZTSAVE("BAR*")=""
D ^%ZTLOAD
I $D(ZTSK)[0 W !!?5,"Report Cancelled!"
E W !!?5,"Report task #: ",$G(ZTSK)
D HOME^%ZIS
Q
;
PRINT ;EP - PRINT THE LETTER
N LTRIEN,LINE
K DIC,DIR,DR,DA,DIE
S X=BARLTR
S DIC="^BAR(90052.03,"
S DIC(0)="QELM"
D ^DIC
I Y<0 W !,"CANNOT FIND '"_BARLTR_" IN A/R LETTERS & TEXT FILE" Q
;TRAVERSE THE LETTER
S LTRIEN=+Y
S LINE=0
F S LINE=$O(^BAR(90052.03,LTRIEN,1,LINE)) Q:'LINE D
.S LINETXT=^BAR(90052.03,LTRIEN,1,LINE,0)
.Q:$E(LINETXT)=";" ;COMMENT LINE
.I $E(LINETXT)="~" X $P(LINETXT,"~",2)
.E W !,LINETXT
I $F("789",LTRIEN)&$G(BARPRTQ)=1 D PUCCMT ; BAR1.8*17 PKD 2/24/2010
Q:'BARSAVE ;BAR*1.8*4 DO NOT SAVE IF THIS IS A REPRINT
D SAVE(BARAMT,BARCOL,BARCHK,BARSCHED,BARINS,LTRIEN,$G(BARRETYP),$G(BARADJT)) ;BAR*1.8*4 SAVE DATA INTO A/R PRINTED LETTERS FILE
Q
;
; BEGIN NEW CODE BAR*1.8.*17
PUCCMT ;
; IF COMMENTS FOR PUC ITEMS, RETRIEVE & PRINT BAR*1.8*17 pkd 2/24/2010
N CMT,DSH,LN
S CMT=0 Q:$G(^BARCOL(DUZ(2),BARTX(14,"I"),1,BARTX(15,"I"),7,0))=""
M CMT=^BARCOL(DUZ(2),BARTX(14,"I"),1,BARTX(15,"I"),7)
S CMT=$P(CMT(0),"^",3) Q:'CMT
S $P(DSH,"=",79)=""
W !!,DSH,!,"Comments:" F LN=1:1:CMT W !,CMT(LN,0)
Q
;
;BAR*1.8*4
SAVE(BARAMT,BARCOL,BARCHK,BARSCHED,BARINS,LTRIEN,BARRETYP,BARADJT) ;
D NOW^%DTC
S (DINUM,X)=%
S DIC(0)=""
S DIC="^BAR(90052,"
S DIC("DR")=".02////^S X=BARDUZ;"
S DIC("DR")=DIC("DR")_".03////^S X=BARDUZ2;"
S DIC("DR")=DIC("DR")_".04////^S X=BARAMT;"
S DIC("DR")=DIC("DR")_".05////^S X=BARCOL;"
S DIC("DR")=DIC("DR")_".06////^S X=BARCHK;"
S DIC("DR")=DIC("DR")_".07////^S X=BARSCHED;"
S DIC("DR")=DIC("DR")_".08////^S X=BARINS;"
S DIC("DR")=DIC("DR")_".09////^S X=LTRIEN;"
I BARLTR["UNBILLED" S DIC("DR")=DIC("DR")_".11////^S X=BARRETYP"
E S DIC("DR")=DIC("DR")_".12////^S X=BARRETYP"
K DO D FILE^DICN
Q
;
REPRINT ;EP - REPRINT ALREADY PRINTED LETTERS
N BARAMT,BARCOL,BARCHK,BARSCHED,BARINS,BARLTR,BARRETYP,BAREXTYP
K NOSAVE
K DIC,DIR,DIE,DA,DR
S DIC(0)="AEMQ"
S DIC="^BAR(90052,"
S DIC("W")="D ID^BARUFLTR"
W !!
D ^DIC
Q:Y<0
S IENS=+Y_","
S BARDUZ=$$GET1^DIQ(90052,IENS,.02,"I")
S BARDUZ2=$$GET1^DIQ(90052,IENS,.03,"I")
S BARAMT=$$GET1^DIQ(90052,IENS,.04,"I")
S BARCOL=$$GET1^DIQ(90052,IENS,.05,"I")
S BARCHK=$$GET1^DIQ(90052,IENS,.06,"I")
S BARSCHED=$$GET1^DIQ(90052,IENS,.07,"I")
S BARINS=$$GET1^DIQ(90052,IENS,.08,"I")
S BARLTR=$$GET1^DIQ(90052,IENS,.09,"E")
S BARRETYP=$$GET1^DIQ(90052,IENS,.11,"I")
S BARRETYP=BARRETYP_" "_$$GET1^DIQ(90052,IENS,.11,"E")
S BARSAVE=0
D LETTER1
Q
;
ID ;EP- DISPLAY LIST FOR 'A/R PRINTED LETTERS'
;+Y IS INTERNAL IEN
N TYPE
S TYPE=$$GET1^DIQ(90052,+Y_",",.09,"E")
W ?22,$P(TYPE," LETTER") ;TYPE OF LETTER
W ?45,$J($$GET1^DIQ(90052,+Y_",",.04,"E"),10,2) ;AMOUNT
W !?27,$S(TYPE["UNBILLED":$$GET1^DIQ(90052,+Y_",",.11,"I"),1:$$GET1^DIQ(90052,+Y_",",.12,"I")) ;TYPE OF REIMBURSEMENT OR ADJUSTMENT TYPE
W !?6,$$GET1^DIQ(90052,+Y_",",.05,"I")
W ?60,$$GET1^DIQ(90052,+Y_",",.02,"E") ;USER
Q
BARUFLTR ; IHS/SD/TPF - UFMS LETTERS ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,17**;OCT 22, 2008
+2 QUIT
+3 ;
+4 ;LETTER(BARAMT,BARCOL,BARCHK,BARSCHED,BARINS,BARLTR) ;EP - PRINT LETTER
LETTER(BARAMT,BARCOL,BARCHK,BARSCHED,BARINS,BARLTR,BARRETYP,BARADJT) ;EP - PRINT LETTER ;BAR*1.8*4
+1 SET BARSAVE=1
LETTER1 ;EP -
+1 SET Y=DT
XECUTE ^DD("DD")
+2 SET BAREXNOW=Y
+3 ;S BARDUZ=DUZ
+4 ;S BARDUZ2=DUZ(2)
+5 ;BAR*1.8*4 IF THESE ARE SET THE CALL IF FROM THE REPRINT OPTION
IF '$GET(BARDUZ)
SET BARDUZ=DUZ
+6 IF '$GET(BARDUZ2)
SET BARDUZ2=DUZ(2)
+7 WRITE !!,"Select device to print Finance letter..."
+8 SET %ZIS("B")=""
+9 SET %ZIS="MQO"
+10 DO ^%ZIS
+11 IF POP
QUIT
+12 ;I IO=IO(0) W !!,"CAN'T PRINT LETTER TO THE SCREEN!!" H 2 G LETTER1 ;BAR*1.8*4 SCR56
+13 IF $DATA(IO("Q"))
DO QUE
QUIT
+14 USE IO
+15 DO PRINT
+16 WRITE @IOF
+17 DO ^%ZISC
+18 QUIT
QUE ; EP - QUE 'NOT SENT' OR 'DELAY SEND' REPORT
+1 SET ZTRTN="PRINT^BARUFLTR"
+2 SET ZTDESC=BARLTR
+3 SET ZTSAVE("BAR*")=""
+4 DO ^%ZTLOAD
+5 IF $DATA(ZTSK)[0
WRITE !!?5,"Report Cancelled!"
+6 IF '$TEST
WRITE !!?5,"Report task #: ",$GET(ZTSK)
+7 DO HOME^%ZIS
+8 QUIT
+9 ;
PRINT ;EP - PRINT THE LETTER
+1 NEW LTRIEN,LINE
+2 KILL DIC,DIR,DR,DA,DIE
+3 SET X=BARLTR
+4 SET DIC="^BAR(90052.03,"
+5 SET DIC(0)="QELM"
+6 DO ^DIC
+7 IF Y<0
WRITE !,"CANNOT FIND '"_BARLTR_" IN A/R LETTERS & TEXT FILE"
QUIT
+8 ;TRAVERSE THE LETTER
+9 SET LTRIEN=+Y
+10 SET LINE=0
+11 FOR
SET LINE=$ORDER(^BAR(90052.03,LTRIEN,1,LINE))
IF 'LINE
QUIT
Begin DoDot:1
+12 SET LINETXT=^BAR(90052.03,LTRIEN,1,LINE,0)
+13 ;COMMENT LINE
IF $EXTRACT(LINETXT)=";"
QUIT
+14 IF $EXTRACT(LINETXT)="~"
XECUTE $PIECE(LINETXT,"~",2)
+15 IF '$TEST
WRITE !,LINETXT
End DoDot:1
+16 ; BAR1.8*17 PKD 2/24/2010
IF $FIND("789",LTRIEN)&$GET(BARPRTQ)=1
DO PUCCMT
+17 ;BAR*1.8*4 DO NOT SAVE IF THIS IS A REPRINT
IF 'BARSAVE
QUIT
+18 ;BAR*1.8*4 SAVE DATA INTO A/R PRINTED LETTERS FILE
DO SAVE(BARAMT,BARCOL,BARCHK,BARSCHED,BARINS,LTRIEN,$GET(BARRETYP),$GET(BARADJT))
+19 QUIT
+20 ;
+21 ; BEGIN NEW CODE BAR*1.8.*17
PUCCMT ;
+1 ; IF COMMENTS FOR PUC ITEMS, RETRIEVE & PRINT BAR*1.8*17 pkd 2/24/2010
+2 NEW CMT,DSH,LN
+3 SET CMT=0
IF $GET(^BARCOL(DUZ(2),BARTX(14,"I"),1,BARTX(15,"I"),7,0))=""
QUIT
+4 MERGE CMT=^BARCOL(DUZ(2),BARTX(14,"I"),1,BARTX(15,"I"),7)
+5 SET CMT=$PIECE(CMT(0),"^",3)
IF 'CMT
QUIT
+6 SET $PIECE(DSH,"=",79)=""
+7 WRITE !!,DSH,!,"Comments:"
FOR LN=1:1:CMT
WRITE !,CMT(LN,0)
+8 QUIT
+9 ;
+10 ;BAR*1.8*4
SAVE(BARAMT,BARCOL,BARCHK,BARSCHED,BARINS,LTRIEN,BARRETYP,BARADJT) ;
+1 DO NOW^%DTC
+2 SET (DINUM,X)=%
+3 SET DIC(0)=""
+4 SET DIC="^BAR(90052,"
+5 SET DIC("DR")=".02////^S X=BARDUZ;"
+6 SET DIC("DR")=DIC("DR")_".03////^S X=BARDUZ2;"
+7 SET DIC("DR")=DIC("DR")_".04////^S X=BARAMT;"
+8 SET DIC("DR")=DIC("DR")_".05////^S X=BARCOL;"
+9 SET DIC("DR")=DIC("DR")_".06////^S X=BARCHK;"
+10 SET DIC("DR")=DIC("DR")_".07////^S X=BARSCHED;"
+11 SET DIC("DR")=DIC("DR")_".08////^S X=BARINS;"
+12 SET DIC("DR")=DIC("DR")_".09////^S X=LTRIEN;"
+13 IF BARLTR["UNBILLED"
SET DIC("DR")=DIC("DR")_".11////^S X=BARRETYP"
+14 IF '$TEST
SET DIC("DR")=DIC("DR")_".12////^S X=BARRETYP"
+15 KILL DO
DO FILE^DICN
+16 QUIT
+17 ;
REPRINT ;EP - REPRINT ALREADY PRINTED LETTERS
+1 NEW BARAMT,BARCOL,BARCHK,BARSCHED,BARINS,BARLTR,BARRETYP,BAREXTYP
+2 KILL NOSAVE
+3 KILL DIC,DIR,DIE,DA,DR
+4 SET DIC(0)="AEMQ"
+5 SET DIC="^BAR(90052,"
+6 SET DIC("W")="D ID^BARUFLTR"
+7 WRITE !!
+8 DO ^DIC
+9 IF Y<0
QUIT
+10 SET IENS=+Y_","
+11 SET BARDUZ=$$GET1^DIQ(90052,IENS,.02,"I")
+12 SET BARDUZ2=$$GET1^DIQ(90052,IENS,.03,"I")
+13 SET BARAMT=$$GET1^DIQ(90052,IENS,.04,"I")
+14 SET BARCOL=$$GET1^DIQ(90052,IENS,.05,"I")
+15 SET BARCHK=$$GET1^DIQ(90052,IENS,.06,"I")
+16 SET BARSCHED=$$GET1^DIQ(90052,IENS,.07,"I")
+17 SET BARINS=$$GET1^DIQ(90052,IENS,.08,"I")
+18 SET BARLTR=$$GET1^DIQ(90052,IENS,.09,"E")
+19 SET BARRETYP=$$GET1^DIQ(90052,IENS,.11,"I")
+20 SET BARRETYP=BARRETYP_" "_$$GET1^DIQ(90052,IENS,.11,"E")
+21 SET BARSAVE=0
+22 DO LETTER1
+23 QUIT
+24 ;
ID ;EP- DISPLAY LIST FOR 'A/R PRINTED LETTERS'
+1 ;+Y IS INTERNAL IEN
+2 NEW TYPE
+3 SET TYPE=$$GET1^DIQ(90052,+Y_",",.09,"E")
+4 ;TYPE OF LETTER
WRITE ?22,$PIECE(TYPE," LETTER")
+5 ;AMOUNT
WRITE ?45,$JUSTIFY($$GET1^DIQ(90052,+Y_",",.04,"E"),10,2)
+6 ;TYPE OF REIMBURSEMENT OR ADJUSTMENT TYPE
WRITE !?27,$SELECT(TYPE["UNBILLED":$$GET1^DIQ(90052,+Y_",",.11,"I"),1:$$GET1^DIQ(90052,+Y_",",.12,"I"))
+7 WRITE !?6,$$GET1^DIQ(90052,+Y_",",.05,"I")
+8 ;USER
WRITE ?60,$$GET1^DIQ(90052,+Y_",",.02,"E")
+9 QUIT
