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