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

ACHSPAZ.m

Go to the documentation of this file. 
  1. ACHSPAZ ; IHS/ITSC/PMF - DOCUMENT PAYMENT - ENTER SVDT,WKLD,FULP,3RDP,VAMT ;    [ 02/02/2005  11:12 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**12,19**;JUN 11, 2001
  1.  ;
  1.  S (ACHSADDT,ACHSDIDT,ACHSDITY,ACHSSVDT,ACHSWKLD,ACHSFULP,ACHS3RDP,ACHS3RDS,ACHSVAMT,ACHSCTL,ACHSCHK,ACHSREM,ACHSSV,ACHSOB,ACHSPACC)=""
  1. A1 ;
  1.  W !!,"Date Of Service: "
  1.  I ACHSSVDT W $$FMTE^XLFDT(ACHSSVDT),"// "
  1.  D READ^ACHSFU
  1.  I $G(ACHSQUIT) D END Q
  1.  I Y?1"?".E W !,"  Enter The Date The Patient First Received Treatment" G A1
  1.  I Y="" G A3:ACHSSVDT W !!,"Must enter Date of Service" G A1
  1.  S X=Y,%DT="EXQP"
  1.  D ^%DT
  1.  I Y<1 S ACHSSVDT="" G A1
  1.  I Y<ACHSODT S ACHSSVDT=Y W *7,!,"SERVICE date is before ORDER date.",! G A2
  1.  S ACHSSVDT=Y
  1.  G A3
  1.  ;
  1. A2 ;
  1.  S Y=$$DIR^XBDIR("Y","Are You Sure This Is Correct ","NO","","","",2)
  1.  I $D(DTOUT) D END Q
  1.  G A1:$D(DUOUT)!('Y)
  1. A3 ;
  1.  S Y=$$DIR^XBDIR("N^1:9999:0","Workload Units",$G(ACHSWKLD),""," Enter # of Visits, Days &/or Tests","",2)
  1.  I $D(DTOUT) D END Q
  1.  G A1:$D(DUOUT)
  1.  S ACHSWKLD=Y
  1.  ;
  1. A3A ; Set O/P visit to Hospital node
  1.  ;
  1.  ;GET OBJECT CLASSIFICATION PTR THEN GET CODE
  1.  ;254D = PHYS OUTP NON-IHS
  1.  I $$DOC^ACHS(0,7) I $P(^ACHS(3,DUZ(2),1,$$DOC^ACHS(0,7),0),U)'="254D" G A4
  1.  ;GET PROVIDER (VENDOR) PTR THEN GET PROVIDER TYPE
  1.  I $$DOC^ACHS(0,8) I +$P(^AUTTVNDR($$DOC^ACHS(0,8),11),U,3)'="" I $D(^AUTTVTYP(+$P($G(^AUTTVNDR($$DOC^ACHS(0,8),11)),U,3),0)) S %=$P(^(0),U) I (%="05")!(%="06") G A4
  1.  D DIR("9002080.02,9.1^O",$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTDA,0)),U,16))
  1.  I $D(DTOUT) D END Q
  1.  G A3:$D(DUOUT)
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTDA,0),U,16)=Y  ;HOSPITAL OUTPATIENT
  1. A4 ;
  1.  ;
  1.  D ^ACHSPAA                   ;DOCUMENT PAYMENT ENTER/EDIT AMOUNT
  1.  I $D(DTOUT) D END Q          ;RETURNED VARS ACHSIPA,ACHSVAMT,ACHSPAMT   
  1.  G A3:$D(DUOUT)
  1.  ;
  1.  I +ACHSVAMT=0 S ACHSFULP="P" G A6
  1. A5 ;
  1.  S ACHSFULP=$$DIR^XBDIR("9002080.02,4","Payment Status",$G(ACHSFULP),"","","",2)
  1.  G A4:$D(DUOUT),END:$D(DTOUT)
  1.  I '$L(ACHSFULP) W "  Required" G A5
  1. A6 ;
  1.  I ACHSFULP="F" S (ACHS3RDP,ACHS3RDS)="" G A7A
  1. A7 ;
  1.  W !!,"Enter Amount Paid by all Third Parties: "
  1.  I ACHS3RDP S X=ACHS3RDP D FMT^ACHS W "//"
  1.  D READ^ACHSFU
  1.  I $D(DTOUT) D END Q
  1.  G A5:$D(DUOUT)
  1.  I Y?1"?".E W !," Enter difference between total bill and amount paid by IHS" G A6
  1.  I Y="" G SRC:ACHS3RDP
  1.  S ACHS3RDP=$J(Y,0,2)
  1.  W "   ("
  1.  S X=ACHS3RDP
  1.  D FMT^ACHS
  1.  W ")"
  1. SRC ; 3P source
  1.  S ACHS3RDS=$P($G(^AUTNINS(+$G(ACHS3RDS),0)),U)  ;'NAME' FROM 'INSURER'
  1.  D DIR("9002080.02,12^O",$G(ACHS3RDS))
  1.  I $D(DTOUT) D END Q
  1.  G A5:$D(DUOUT)
  1.  S ACHS3RDS=$S(+Y>0:+Y,1:"")
  1.  ;
  1. A7A ; Pay indicator: Final/Interim
  1.  S:'$D(ACHSF638) ACHSF638=$P(^ACHSF(DUZ(2),0),U,8)
  1.  I $$DOC^ACHS(0,17)="I" S ACHSPIND="F" G A7C
  1.  D DIR("9002080.02,15",$$EXTSET^XBFUNC(9002080.02,15,$G(ACHSPIND)))
  1.  G A5:$D(DUOUT),END:$D(DTOUT)
  1.  I '$L(Y) W *7,"  Required" G A7A
  1.  S ACHSPIND=Y
  1.  ;
  1. A7C ; EOBR pay date
  1.  ;I ACHSF638="Y" S ACHSPDAT=DT G A8
  1.  I $$PARM^ACHS(2,11)'="Y",ACHSF638="Y" S ACHSPDAT=DT G A8    ;ACHS*3.1*19 IHS/OIT.FCJ ADDED FOR TRIBAL SITES USING THE FI
  1.  D DIR("9002080.02,13",$$FMTE^XLFDT($G(ACHSPDAT),1))
  1.  I $D(DTOUT) D END Q
  1.  G A5:$D(DUOUT)
  1.  I '$L(Y) W *7,"  Required" G A7C
  1.  S ACHSPDAT=Y
  1.  G:$$DOC^ACHS(0,17)'="F" A8   ;DOCUMENT DESTINATION  F= FI
  1.  ;
  1. A7D ; EOBR Control Number
  1.  ;G:ACHSF638="Y" A8
  1.  I $$PARM^ACHS(2,11)'="Y",ACHSF638="Y" S ACHSPDAT=DT G A8    ;ACHS*3.1*19 IHS/OIT.FCJ ADDED FOR TRIBAL SITES USING THE FI
  1.  D DIR("9002080.02,16",$G(ACHSCTL))
  1.  I $D(DTOUT) D END Q
  1.  G A5:$D(DUOUT)
  1.  I '$L(Y) W *7,"  Required" G A7D
  1.  S ACHSCTL=Y
  1.  ;
  1. A7E ; EOBR Check number
  1.  D DIR("9002080.02,17",$G(ACHSCHK))
  1.  I $D(DTOUT) D END Q
  1.  G A5:$D(DUOUT)
  1.  I '$L(Y) W *7,"  Required" G A7E
  1.  S ACHSCHK=Y
  1.  ;
  1. A7F ; EOBR Remittance number
  1.  D DIR("9002080.02,18",$G(ACHSREM))
  1.  I $D(DTOUT) D END Q
  1.  G A5:$D(DUOUT)
  1.  I '$L(Y) W *7,"  Required" G A7F
  1.  S ACHSREM=Y
  1.  ;
  1. A7G ; EOBR Services
  1.  D DIR("9002080.02,19",$$EXTSET^XBFUNC(9002080.02,19,$G(ACHSSV)))
  1.  I $D(DTOUT) D END Q
  1.  G A5:$D(DUOUT)
  1.  I '$L(Y) W *7,"  Required" G A7G
  1.  S ACHSSV=Y
  1.  ;
  1. A7H ; EOBR Obligation type
  1.  D DIR("9002080.02,20",$$EXTSET^XBFUNC(9002080.02,20,$G(ACHSOB)))
  1.  I $D(DTOUT) D END Q
  1.  G A5:$D(DUOUT)
  1.  I '$L(Y) W *7,"  Required" G A7H
  1.  S ACHSOB=Y
  1.  ;
  1. A8 ;
  1.  ;ITSC/SET/JVK 1.25.05 ACHS*3.1*12 NXT 4 LINES PATIENT ACCT NO
  1.  I ACHSF638="Y" D
  1.  .S DIR(0)="9002080.01,26.01"
  1.  .S DIR("A")="Patient Account #"
  1.  .D ^DIR
  1.  .S ACHSPACC=Y
  1.  .K DIR
  1.  .Q
  1.  S ACHSPSQN=$G(^ACHSF(DUZ(2),"SEQN"))+1
  1.  S ^ACHSF(DUZ(2),"SEQN")=ACHSPSQN
  1.  S Y=$$DIR^XBDIR("Y","Are All Entries Correct","NO","","","",2)
  1.  G END:$D(DTOUT),A3:$D(DUOUT),A1:'Y
  1.  S ACHSSET=1
  1.  W !!,"***  Document Paid  ***"
  1.  I $P(^ACHSF(DUZ(2),0),U,8)="Y",$P(^(0),U,9)="Y" S ^ACHS(7,"CHS 638 CHECKS",DUZ(2),ACHSDIEN)="" W !!,"***  Document added to Check-print list.  ***"
  1. END ;
  1.  K ACHSVAMT,X2,X3
  1.  Q
  1.  ;
  1. DIR(ACHS,ACHS1) ; ( <DIR(0)> , <DIR("B")> )
  1.  W !
  1.  K DIR,DUOUT,DTOUT,DIRUT
  1.  S DIR(0)=ACHS
  1.  I $L($G(ACHS1)) S DIR("B")=ACHS1
  1.  D ^DIR
  1.  K DIR
  1.  Q
  1.  ;