Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BZSMAWO2

BZSMAWO2.m

Go to the documentation of this file. 
  1. BZSMAWO2 ; IHS/TAO/EDE - WRITE OFF OLD BILLS [ 05/23/2003  7:42 PM ]
  1.  ;;1.0;TUCSON AREA OFFICE W/O;;MAR 14, 2003
  1.  ;
  1.  ; This routine does the actual write off of bills based on
  1.  ; the criteria setup by the calling routine.
  1.  ;
  1. START ; WRITE OFF BILLS
  1.  S BZSDDSV=^DD(9002274.4,3,0) ;          save payment mult dd entry
  1.  S ^DD(9002274.4,3,0)="PAYMENT^9002274.403DA^^3;0" ;set to don't ask
  1.  D LOOPDUZ
  1.  S ^DD(9002274.4,3,0)=BZSDDSV ;          restore to orig
  1.  D EN^XBVK("BAR"),EN^XBVK("AMB")
  1.  Q
  1.  ;
  1.  ;--------------------
  1. LOOPDUZ ; LOOP THRU A/R BILLS BY DUZ(2)
  1.  S BZSDUZ=0
  1.  F  S BZSDUZ=$O(^BARBL(BZSDUZ)) Q:'+BZSDUZ  D LOOPDT
  1.  Q
  1.  ;
  1.  ;--------------------
  1. LOOPDT ; LOOP THRU A/R BILLS BY DATE OF SERVICE
  1.  S BZSVISIT=0
  1.  F  S BZSVISIT=$O(^BARBL(BZSDUZ,"E",BZSVISIT)) Q:'+BZSVISIT  D
  1.  .  Q:BZSVISIT>BZSEDOS  ;               skip dos after end of tf
  1.  .  Q:BZSVISIT<BZSBDOS  ;               skip dos before beginning of tf
  1.  .  D LOOPBIL
  1.  .  Q
  1.  Q
  1.  ;
  1.  ;--------------------
  1. LOOPBIL ; LOOP THRU A/R BILLS FOR SINGLE DATE OF SERVICE
  1.  S BZSBL2=0
  1.  F  S BZSBL2=$O(^BARBL(BZSDUZ,"E",BZSVISIT,BZSBL2)) Q:'+BZSBL2  D WRITEOFF
  1.  Q
  1.  ;
  1.  ;--------------------
  1. WRITEOFF ; WRITE OFF BILLS THAT MEET CRITERIA
  1.  Q:'$D(^BARBL(BZSDUZ,BZSBL2))           ; No bill data
  1.  S BZS(0)=$G(^BARBL(BZSDUZ,BZSBL2,0))   ; A/R Bill 0 node
  1.  S BZS(1)=$G(^BARBL(BZSDUZ,BZSBL2,1))   ; A/R Bill 0 node
  1.  S BZSBAL=$P(BZS(0),U,15)               ; Bill Balance
  1.  S BZSAMT=$P(BZS(0),U,13)               ; Billed Amount
  1.  S BZSVSTL=$P(BZS(1),U,8)               ; Visit location
  1.  ; Q if A/R account is not on bill
  1.  Q:$P(BZS(0),U,3)=""
  1.  ; Q if visit location not in list
  1.  ;I $D(BZS("LOC")),'$D(BZS("LOC",BZSVSTL)) Q
  1.  ; Q if A/R account not in list
  1.  I $D(BZS("ACCT")),'$D(BZS("ACCT",$P(BZS(0),U,3))) Q
  1.  S BZSACT=$P(BZS(0),U,3)                ;A/R Account
  1.  S BZSITYP=$$GET1^DIQ(90050.02,BZSACT,1.08)
  1.  I BZSBAL'>0 D  Q                       ; Don't want 0 or credit bal
  1.  . S ^BZSTMP("BZSAWO",BZSDUZ,DT,DUZ,"CREDIT",BZSBL2)=""
  1.  I BZSAMT>20000 D  Q                    ; May only write-off $20,000
  1.  . S ^BZSTMP("BZSAWO",BZSDUZ,DT,DUZ,"TOO HIGH",BZSBL2)=""
  1.  S DUZ(2)=BZSDUZ
  1.  S BZSTRIEN=$$NEW^BARTR                 ; Create new transaction
  1.  S DA=BZSTRIEN
  1.  S DIE=90050.03
  1.  S DR="2////^S X=BZSBAL"                ; Credit ($$$)
  1.  S DR=DR_";4////^S X=BZSBL2"            ; A/R Bill
  1.  S DR=DR_";5////^S X=$P(BZS(1),U)"      ; A/R Patient
  1.  S DR=DR_";6////^S X=$P(BZS(0),U,3)"    ; A/R Account
  1.  S DR=DR_";8////^S X=DUZ(2)"            ; Parent Location
  1.  S DR=DR_";9////^S X=DUZ(2)"            ; Parent ASUFAC
  1.  S DR=DR_";10////^S X=BZSSECT"          ; A/R Section
  1.  S DR=DR_";11////^S X=$P(BZS(1),U,8)"   ; Visit location
  1.  S DR=DR_";12////^S X=DT"               ; Date
  1.  S DR=DR_";13////^S X=DUZ"              ; A/R Entry by
  1.  S DR=DR_";101////43"                   ; Transaction type (Adj)
  1.  S DR=DR_";102////3"                    ; Adj Category (Write off)
  1.  S DR=DR_";103////1003"                 ; Adj Type (Auto write off)
  1.  S DIDEL=90050
  1.  D ^DIE                                 ; Populate transaction file
  1.  K DIDEL,DIE,DA,DR
  1.  D TR^BARTDO(BZSTRIEN)                  ; Post from Trans to files
  1.  K BZSBL
  1.  S BZSCNT=BZSCNT+1
  1.  W !,$P(BZS(0),U),?25," for ",$J($FN(BZSBAL,",",2),10)," written off."
  1.  S ^BZSTMP("BZSAWO",DT,DUZ,"DONE",BZSBL2)=$P(BZS(0),U)_U_BZSBAL
  1.  D ROLLBILL                             ; Roll info to 3PB
  1.  Q
  1.  ;
  1.  ;--------------------
  1. ROLLBILL ; UPDATE PAYMENT MULTIPLE IN 3P, MARK COMPLETE AND ROLLED
  1.  ; For bills written off, update Payment multiple in 3P and mark bill
  1.  ; complete in 3PB.  Also mark bill as rolled in A/R
  1.  S BARBLDA=BZSBL2
  1.  K BARBL
  1.  D SETVAR^BARROLL                       ; Set A/R vars to roll to 3PB
  1.  D ROLL
  1.  D SETBLRL^BARROLL                      ; Mark bill as rolled
  1.  Q
  1.  ;
  1.  ;--------------------
  1. ROLL ; ROLL A/R VARS TO 3PB
  1.  K DIE,DA,DR
  1.  S BZS3PNM=BARBL(.01)
  1.  S:(BZS3PNM["-") BZS3PNM=$P(BZS3PNM,"-")
  1.  S BZS3PDA=BARBL(17)
  1.  Q:BZS3PDA'>0
  1.  S Y=+BZS3PDA
  1.  S DIC=$$DIC^XBDIQ1(9002274.4)
  1.  S DUZO2=DUZ(2)
  1.  I DIC["DUZ(2)" S DUZ(2)=$P($G(^BARBL(DUZO2,BARBLDA,1)),U,8)
  1.  S:'$D(^ABMDBILL(DUZ(2),"B",BZS3PNM)) DUZ(2)=$P($G(^BARBL(DUZO2,BARBLDA,1)),U,8)
  1.  S Y=Y_"^"_DUZ(2)
  1.  S BZSGBL=DIC_+Y_")"
  1.  I $D(@BZSGBL) D ROLLTPB                ; Roll to 3PB
  1.  S DUZ(2)=DUZO2
  1.  Q
  1.  ;
  1.  ;--------------------
  1. ROLLTPB ; FILE A/R DATA IN PAYMENT MULTIPLE OF 3PB
  1.  M ABM=BARSUM
  1.  S X=Y
  1.  S ABMP("BDFN")=+X                      ; IEN to 3PB BILL
  1.  S ABMP("BILL")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"^",1)  ; Bill #
  1.  I ABMP("BILL")'=BZS3PNM D LKUP^ABMAROLL
  1.  I 'ABMP("BDFN") Q
  1.  ; File A/R data in payment multiple of 3P BILL and complete bill
  1.  D FILE^ABMAROLL
  1.  Q