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

ACHSA3.m

Go to the documentation of this file. 
  1. ACHSA3 ; IHS/ITSC/PMF - ENTER DOCUMENTS (4/8)-(CON,DESC,PRD,ONUM) ;   [ 09/22/2004  3:39 PM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**11**;JUN 11, 2001;Build 43
  1.  ;ITSC/SET/JVK ACHS*3.1*11 MODIFIED TO DISPLAY MEDICARE PROVIDER
  1.  ;
  1. B4 ;
  1.  S ACHSACO=""  ;FOR USE IN ACHSUCN
  1.  ;
  1.  D ^ACHSUCN    ;SELECT OR PRINT VENDOR CONTRACT INFO; SETS UP ACHSRT( 
  1.  ;
  1.  ;C=NUMBER OF VALID CONTRACTS FOUND
  1.  ;L= ARRAY OF CONTRACT PTR^WEIRD SERVICE DATE^CONTRACT NUMBER
  1.  I C=1 S ACHSCONP=$P(L,U)
  1.  S:$D(ACHSPROV) P=ACHSPROV
  1.  ;
  1.  ;
  1.  D A1^ACHSURT              ;SELECT DISPLAY RATE QUOTATIONS ,USES ACHSRT(
  1.  ;
  1.  D CARE
  1.  I ACHSACO="N" G B6A             ;MEANS NO CONTRACTS IN FORCE
  1.  ;
  1.  I ACHSCTNA=0!(ACHSCTNA>C) G R1
  1.  ;
  1. B5 ; Enter contract number of vendor
  1.  W !!,"Contract Number: "
  1.  I ACHSCONP,$D(^AUTTVNDR(ACHSPROV,"CN",ACHSCONP,0)) W $P($G(^AUTTVNDR(ACHSPROV,"CN",ACHSCONP,0)),U),"// " G B5B
  1.  G B6:C>1
  1. B5B ;
  1.  D READ^ACHSFU
  1.  I $G(ACHSQUIT) D END^ACHSA Q
  1.  ;
  1.  ;GO BACK TO ENTER DATE OF SERVICE
  1.  G B5^ACHSA1:$D(DUOUT),B6:Y?1"?".E,R1:Y=""
  1.  ;
  1.  S C=0
  1.  I Y="@" S ACHSCONP="" W "  Deleted" G R1
  1.  ;
  1.  ;??????
  1.  I Y]"",$L(Y)<32 D
  1.  .S N=""
  1.  .F I=1:1 S N=$O(^AUTTVNDR(ACHSPROV,"CN","AB",Y,N)) Q:N=""  I $D(^AUTTVNDR(ACHSPROV,"CN",N,0)),ACHSFDT'>$P($G(^AUTTVNDR(ACHSPROV,"CN",N,0)),U,3),ACHSFDT'<$P($G(^AUTTVNDR(ACHSPROV,"CN",N,0)),U,2) S C=C+1,L=N
  1.  I C=1 S ACHSCONP=L G B5
  1.  W *7,"  ??"
  1. B6 ;
  1.  S ACHSACO="L"         ;
  1.  ;
  1.  ;WE JUST DID THIS ABOVE?????
  1.  D ^ACHSUCN      ;SELECT OR PRINT VENDOR CONTRACT INFO; SETS UP ACHSRT(
  1.  ;
  1. B6A ;
  1.  I 'C,ACHSACO="N" W !!,"  No Contracts Currently in Force For This Vendor" G R1
  1. B7 ;
  1.  W !!,"Which One: "
  1.  D READ^ACHSFU
  1.  I $G(ACHSQUIT) D END^ACHSA Q
  1.  ;
  1.  ;RETURN TO SELECT PROVIDER / VENDOR
  1.  G B5A^ACHSA1:$D(DUOUT)
  1.  ;
  1.  I Y?1"?".E W "   Select 1 Thru ",(C+1) G B7
  1.  G B5:Y=""
  1.  I Y<1!(Y>(C+1)) W *7,"  ????" G B7
  1.  I Y=(C+1) S ACHSCONP="" W !!,"Contract Number: Open Market// " G B5B
  1.  S ACHSACO="F",F=Y
  1.  ;
  1.  ;5/11/01  pmf  taking out this call to ACHSUCN.  don't know why
  1.  ;we go there at this point, and we're coming back wrong.
  1.  ;D ^ACHSUCN      ;SELECT OR PRINT VENDOR CONTRACT INFO; SETS UP ACHSRT(
  1.  ;
  1.  ;5/11/01   pmf   also replacing this check and set with a better one
  1.  ;I C'=F W *7,"  ??" K ACHSCONP G B5
  1.  ;S ACHSCONP=$P(L,U)
  1.  ;
  1.  S ACHSCONP=$P(ACHSRT(Y),U,11)
  1.  G B5
  1.  ;
  1. R1 ; Display rate/AGR quotes for vendors.
  1.  G:'$D(ACHSRT(0,"ACTIVE")) B10
  1.  I ACHSCTNA'>C G R10
  1.  ;
  1.  ;DONE ABOVETO TAG A1 WHY TWICE?????
  1.  D A2^ACHSURT         ;SELECT DISPLAY RATE QUOTATIONS ,USES ACHSRT(
  1.  ;
  1. R10 ;
  1.  I +ACHSAGRP=0 G B10
  1.  ;
  1.  ;'MEDICARE RATE FOR INPATIENT'
  1.  S:ACHSTYP=1 ACHSDRG=$P($G(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0)),U,4)
  1.  ;
  1.  ;'MEDICARE RATE FOR OUTPATIENT'
  1.  S:ACHSTYP=3 ACHSCONP=$P($G(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0)),U,5)
  1. B10 ;
  1.  I ACHSTYP=2 G B20    ;IF DENTAL SERVICE BYPASS DESCRIPTION
  1.  ;ITSC/SET/JVK ACHS*3.1*11 MODIFIED TO SELECT MEDICARE PROVIDER NO.
  1.  S ACHSMPN=$P($G(^AUTTVNDR(ACHSPROV,23)),U) I ACHSMPN'="Y" S ACHSMPN="" G B20
  1.  I ACHSTYP'=1 G B20
  1.  I ACHSMPN="Y" S Y=$$DIR^XBDIR("Y","Want to use the Medicare like Rate","NO","","","",2)
  1.  I 'Y S (ACHSMPN,ACHSDS,ACHSMPP)="" G B20
  1.  I Y S Y=+$$DIR^XBDIR("NO^1:"_CT,"Enter the number","","","","",2)
  1.  I Y>0  S ACHSCONP="",ACHSMPN=ACHSMPN(Y),ACHSMPP=Y,ACHSDS=$P(ACHSMPN(Y),U,2)
  1.  I ACHSDS S ACHSDES=$$EXTSET^XBFUNC(9999999.112303,2,ACHSDS)
  1.  ;ITSC/SET/JVK ACHS*3.1*11 END OF MODIFICATION
  1.  ;
  1. B20 ; Enter description of service.
  1.  D DUPCK
  1.  K DIR
  1.  S DIR(0)="9002080.01,26"
  1.  S:$G(ACHSDES)]"" DIR("B")=ACHSDES
  1.  W !,$$PRMT^ACHSFU(22,ACHSDES,30)   ;(TAB,VAR,LENGTH) FORMAT PRINT
  1.  K DA
  1.  D ^DIR,DIRD^ACHSFU:X="@"
  1.  I $D(DTOUT) D END^ACHSA Q
  1.  G B5^ACHSA1:$D(DUOUT)&(ACHSTYP=2),A3^ACHSA:$D(DUOUT)
  1.  S ACHSDES=Y
  1.  K DIR
  1. C1 ; Enter period of authorization (From/To dates).
  1.  S ACHSFDT=ACHSEDOS
  1.  ;
  1.  ;IF TYPE OF SERVICE = HOSPITAL SKIP AUTH DATES
  1.  I ACHSTYP=1 G C1A
  1.  W !!,"Period Of Authorization"
  1. A1 ;
  1.  ;ACHS*3.1*23333333 BE SURE TO CHANGE BACK TO 120 DAYS....
  1.  ;S Y=$$DIR^XBDIR("D^:"_$$HTFM^XLFDT($H+120)_":E","From Date",$$FMTE^XLFDT($G(ACHSFDT)),"","Enter a Date Not More Than 120 Days from Today")
  1.  S Y=$$DIR^XBDIR("D^:"_$$HTFM^XLFDT($H+360)_":E","From Date",$$FMTE^XLFDT($G(ACHSFDT)),"","Enter a Date Not More Than 120 Days from Today")
  1.  I $D(DTOUT) D END^ACHSA Q
  1.  G B10:$D(DUOUT)
  1.  S ACHSFDT=Y
  1. A1A ;
  1.  S X1=ACHSFDT,X2=$S(ACHSTYP=2:60,1:10)
  1.  D C^%DTC
  1.  S Y=X,ACHSTDT=Y
  1.  I ACHSTDT,ACHSTDT<ACHSFDT S ACHSTDT=""
  1. A2 ;
  1.  S Y=$$DIR^XBDIR("D^"_ACHSFDT_":"_$$HTFM^XLFDT($$FMTH^XLFDT(ACHSFDT)+120)_":E","To Date",$$FMTE^XLFDT($G(ACHSTDT)),"","Must be After 'From Date' and After Estimated Date Of Service")
  1.  I $D(DTOUT) D END^ACHSA Q
  1.  G A1:$D(DUOUT)
  1.  S ACHSTDT=Y
  1.  I ACHSTDT<ACHSEDOS W !,"** Ending Period Of Authorization Must Be After Estimated Date Of Service **",! G C1
  1.  S ACHSPFYE=($E(ACHSFYDT,1,3)-1)_$P($G(^ACHSF(DUZ(2),0)),U,6)
  1.  S X1=ACHSTDT,X2=ACHSFDT
  1.  D D^%DTC
  1.  I X>120 W *7,!," The Authorization May Not Exceed 120 Days" G A1
  1. C1A ;
  1.  G D1:ACHSTYP'=3  ;IF TYPE OF SERVICE NOT OUTPATIENT SKIP HOSPITAL ORDER
  1. C2 ;
  1.  ;
  1.  D ^ACHSUD1               ;SELECT HOSPITAL ORDER NUMBER
  1.  ;
  1.  I $D(DUOUT) G A3^ACHSA
  1.  G D1:ACHSHON=""
  1.  I '$D(^ACHSF(DUZ(2),"PB",DFN,ACHSHON)) W !!,*7,"Sorry - this document was issued for another patient.",!,"Please Re-enter document number." G C2
  1.  I $P($G(^ACHSF(DUZ(2),"D",ACHSHON,0)),U,4)'=1 W !!,*7,"Sorry - Hospital order number must reference a 43 document.",!,"Please Re-enter document number." G C2
  1.  K E,ORD
  1. D1 ;
  1.  I ACHSCONP D CONCHK G B4:$D(DUOUT)
  1.  ;
  1.  D ^ACHSA4                          ;SELECT DOCUMENTS (CAN)
  1.  ;
  1.  Q
  1. D3 ;
  1.  G B4:ACHSCONP="",B5
  1.  Q
  1. CONCHK ; Check if contract in effect during From-To dates.
  1.  Q:ACHSTYP=1
  1.  K DUOUT
  1.  Q:'$D(^AUTTVNDR(ACHSPROV,"CN",ACHSCONP,0))
  1.  S X=$G(^AUTTVNDR(ACHSPROV,"CN",ACHSCONP,0))
  1.  Q:ACHSFDT'<$P(X,U,2)&(ACHSFDT'>$P(X,U,3))
  1.  I ACHSTDT Q:ACHSTDT'<$P(X,U,2)&(ACHSTDT'>$P(X,U,3))  Q:ACHSFDT<$P(X,U,2)&(ACHSTDT>$P(X,U,3))
  1.  S DUOUT=""
  1.  W *7,!!,"CONTRACT NOT IN EFFECT ",$$FMTE^XLFDT(ACHSFDT),$S(ACHSTDT:" TO "_$$FMTE^XLFDT(ACHSTDT),1:""),".",!
  1.  Q
  1.  ;
  1.  ;
  1. DUPCK ;
  1.  Q:'$G(DFN)!('$G(ACHSPROV))!('$G(ACHSPATF))
  1.  N D,T,R
  1.  S D=0
  1.  ;GO THROUGH PATIENT PTR X-REF
  1.  F  S D=$O(^ACHSF(ACHSPATF,"PB",DFN,D)) Q:D=""  D
  1.  .;QUIT IF 'PROVIDER (VENDOR)' SAME AS ???
  1.  .Q:$P($G(^ACHSF(ACHSPATF,"D",D,0)),U,8)'=ACHSPROV
  1.  .;
  1.  .;GET AUTH AND REFERRAL 3 NODE
  1.  . S R=$G(^ACHSF(ACHSPATF,"D",D,3))
  1.  .Q:R=""
  1.  .;EST. DATE OF SERVICE ENTERED BY USER = 'ESTIMATED DATE OF SERVICE'
  1.  . D:ACHSEDOS=$P(R,U,9) MSG("Estimated")
  1.  . ;
  1.  .;EST. DATE OF SERVICE ENTERED BY USER '< 'AUTH BEGINNING DATE'
  1.  .;AND EST. DATE OF SERVICE ENTERED BY USER '> 'AUTH ENDING DATE'
  1.  . I ACHSEDOS'<$P(R,U),ACHSEDOS'>$P(R,U,2) D MSG("Authorized")
  1.  . S T=0
  1.  .;
  1.  .;GO THROUGH TRANSACTIONS IF EST. DATE OF SERVICE ENTERED BY USER
  1.  .; ='DATE OF SERVICE' 
  1.  . F  S T=$O(^ACHSF(ACHSPATF,"D",D,"T",T)) Q:T=""  I ACHSEDOS=$P($G(^ACHSF(ACHSPATF,"D",D,"T",T,0)),U,10) D MSG("Payment") Q
  1.  ;
  1.  Q
  1.  ;
  1. MSG(MSG) ;
  1.  W *7,*7,*7,!!,$$C^XBFUNC("Hold on now pardner!  Whoa Nellie!")
  1.  W !!,$$C^XBFUNC("Document "_$P($G(^ACHSF(ACHSPATF,"D",D,0)),U,14)_"-"_$$FC^ACHS(ACHSPATF)_"-"_$P($G(^ACHSF(ACHSPATF,"D",D,0)),U)_" has a "_MSG_" date real close to yours.")
  1.  W !,$$C^XBFUNC("( Continue....if you're sure this isn't a duplicate P.O. )")
  1.  D RTRN^ACHS
  1.  Q
  1.  ;
  1. CARE ;
  1.  ;ITSC/SET/JVK ACHS*3.1*11 MODIFIED TO DISPLAY MEDICARE PROVIDER
  1.  S ACHSMCR=$P($G(^AUTTVNDR(ACHSPROV,23)),U,1),ACHSLDT=$P($G(^AUTTVNDR(ACHSPROV,23)),U,2)
  1.  I ACHSMCR'="",ACHSTYP=1 S ACHSMCR=$$EXTSET^XBFUNC(9999999.11,2301,ACHSMCR) D
  1.  . W !!,"Medicare Provider Status Set to: ",ACHSMCR,!,"Last Updated:",$$FMTE^XLFDT($G(ACHSLDT)),!
  1.  I ACHSMCR="YES" S (ACHSMP,CT)=0  D
  1.  . W !,?20,"Services at Medicare Like Rates",!
  1.  . W "#",?5,"Provider No",?23,"Effect Date",?37,"End Date",?51,"Description",!
  1.  . W ?5,"-----------",?23,"----------",?37,"--------",?51,"-----------"
  1.  . F I=1:1  S ACHSMP=$O(^AUTTVNDR(ACHSPROV,"MP",ACHSMP)) Q:ACHSMP'>0  D
  1.  .. S ACHSMPN(I)=^AUTTVNDR(ACHSPROV,"MP",ACHSMP,0)
  1.  .. I ACHSMPN(I)'="" S CT=CT+1 S ACHSMPN=$P(ACHSMPN(I),U),ACHSBDT=$P(ACHSMPN(I),U,3),ACHSEDT=$P(ACHSMPN(I),U,4),ACHSDS=$P(ACHSMPN(I),U,2)
  1.  .. I $D(ACHSDS) S ACHSDS=$$EXTSET^XBFUNC(9999999.112303,2,ACHSDS)
  1.  .. W !,$J(CT,2),?5,ACHSMPN,?23,$$FMTE^XLFDT($G(ACHSBDT)),?37,$$FMTE^XLFDT($G(ACHSEDT)),?51,$G(ACHSDS),!
  1.  .. W:CT=0 !!,"No Medicare Numbers listed.",!
  1.  .. Q
  1.  .Q
  1.  ;