ACHSA1 ; IHS/ITSC/PMF - ENTER DOCUMENTS (2/8)-(PT,HRN,FAC,EDOS,PRO) ; [ 09/22/2004 3:53 PM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,4,5,6,7,16**;JUNE 11, 2001
;ACHS*3.1*3 new method of display 'other resources'
;ACHS*3.1*4 fix bug in pawnee
;ACHS*3.1*5 12/06/2002 fix another pawnee bug
;ACHS*3.1*6 4/14/2003 Test vendor fields on Fed sites
;ACHS*3.1*7 9/8/2003-Comment out patch 6 items until AUT is ready
;ACHS*3.1*16 10/21/2009 IHS.OIT.FCJ Added test for Vendor CCR
;
;12/4/00 pmf add changes for pawnee special benefit
;
;pawnee change here
I +$P($G(^AUTTLOC(DUZ(2),0)),U,10)=505613 D G @TAG
. N ACHSPWNE S ACHSPWNE=0
. D PAWNEE
. ; either go on, go to the end, or go back.
. ; if no value matches, go to the end.
. ;ACHS*3.1*5 098/26/2002 pmf tag name is wrong
. ;S TAG="END"
. S TAG="ENDC"
. I ACHSPWNE="OK" S TAG="B0C"
. I ACHSPWNE="BACK" S TAG="A3^ACHSA"
. Q
;
B0 ; Get patient name, if not Blanket or Spec. Trans.
;
I $D(ACHSBLKF)!($D(ACHSSLOC)) G B3 ;IF BLANKET FORM OR ????
G B0B:'$D(DFN)!('$D(ACHSHRN)) ;GOTO PATIENT LOOKUP
G B0B:DFN&('$D(^DPT(DFN,0))) ;GOTO PATIENT LOOKUP
S Y=DFN
;
D ^AUPNPAT ;SET STANDARD PATIENT VARIABLES
;
;BEGIN Y2K FIX BLOCK
W !!,"Patient Info: ",$E($P($G(^DPT(DFN,0)),U),U,22),?37,SEX,?39,$E(DOB,4,5),"-",$E(DOB,6,7),"-",$E(DOB,1,3)+1700,?48,SSN,?60,$G(ACHSHRN)
;END Y2K FIX BLOCK
I $G(ACHSREF(.03)) G B0C ;DID %RSE AND FOUND NOWHERE BUT HERE?????
;
;PATIENT LOOKUP
B0B ;
D PTLK^ACHS ;STANDARD CHS PATIENT LOOKUP
K ACHSHRN,ACHSPATF
I $D(DTOUT) D END^ACHSA Q ;KILL VARS AND QUIT
I $D(DUOUT)!'$D(DFN) Q ;GO BACK TO CALLING RTN ACHSA
S Y=DFN
;
D ^AUPNPAT ;POST PATIENT SELECTION VARIABLE SETS
;
B0C ;
I $G(ACHSPATF),$G(ACHSHRN) G B4
;
;IF 'MULT. FACILITY PATIENT LOOKUP' IS NO SKIP TO CHECK ELIGIBILITY
I $$PARM^ACHS(2,5)'="Y" S ACHSPATF=DUZ(2),ACHSHRN=$$HRN^ACHS(DFN,ACHSPATF) G B4
;
B1 ; Display/Select Facility(s) at which Patient is Registered.
;
;IF JUST ONE HRN THIS WILL GET IT ;'HEALTH RECORD NO.' NODE
S ACHS=0
F ACHSPATF=0:0 Q:'$O(^AUPNPAT(DFN,41,ACHSPATF)) D
.S ACHSPATF=$O(^AUPNPAT(DFN,41,ACHSPATF))
.S ACHS=ACHS+1
;
;
I ACHS=0 W !!,"NO CHARTS AVAILABLE!!" G B3
I ACHS=1 S ACHSHRN=$$HRN^ACHS(DFN,ACHSPATF) G B4
S ACHS=0
;
;PRINT OUT THE LIST OF CHARTS AVAILABLE
W !!,"ITM #"," CHART #",?20,"FACILITY NAME",!
F ACHSPATF=0:0 S ACHSPATF=$O(^AUPNPAT(DFN,41,ACHSPATF)) Q:+ACHSPATF=0 S ACHS=ACHS+1,ACHSHRN=$P($G(^AUPNPAT(DFN,41,ACHSPATF,0)),U,2),ACHS(ACHS)=ACHSPATF_U_ACHSHRN W !,$J(ACHS,4),?11,ACHSHRN,?20,$P($G(^DIC(4,ACHSPATF,0)),U)
;
B2 ;
;
S Y=$$DIR^XBDIR("N^1:"_ACHS,"SELECT ITEM # FOR APPROPRIATE FACILITY & CHART # COMBINATION","","","","",2)
Q:$D(DUOUT)
I $D(DTOUT) D END^ACHSA Q
S ACHSHRN=$P(ACHS(+Y),U,2)
S ACHSPATF=$P(ACHS(+Y),U)
G B4
;
B3 ;SECTION USED FOR ENTERING BLANKET DESCRIPTION
;
D ^ACHSA2 ;ENTER DOCUMENT 3 OF 8
;
I $D(DUOUT)!'$D(ACHSBLT) D A3^ACHSA Q
I $G(ACHSQUIT) D END^ACHSA Q
I $D(ACHSBLKF)!($D(ACHSSLOC)) S (ACHSPATF,ACHSHRN)=""
;
B4 ; Check CHS eligible.
G B5:$D(ACHSBLKF)!($D(ACHSSLOC))
;
;IF 'PATIENT ADDRESS REQUIRED'
I $$PARM^ACHS(2,4)'="N" G NOCITY:'$D(^DPT(DFN,.11)) G NOCITY:$P($G(^DPT(DFN,.11)),U,4)=""!($P($G(^DPT(DFN,.11)),U,5)="")
;
;
;1/11/02 pmf rewrote ACHSRP31 as ACHSRPIN. new version is
;smaller, faster, cleaner, WORKS better, more modular, more
;usable, easier to read, better commented, and so on.
;S ACHSTAB=0 ; ACHS*3.1*3
;D EN^ACHSRP31 ;ACHS*3.1*3
D GET^ACHSRPIN,PRT^ACHSRPIN ; ACHS*3.1*3
;K ACHSTAB ; ACHS*3.1*3
;
;
;IF 'CHECK FOR CHS ELIGIBILITY'
I $$PARM^ACHS(2,8)="N" W !!,"'",$P($G(^DD(9002080,14.08,0)),U),"' parameter = '",$$PARM^ACHS(2,8),"'.",!!,"CHS Eligibility not checked.",!,"Parameter 'CHECK FOR CHS ELIGIBILITY' not set." G B5
;
;
I '$D(^AUPNPAT(DFN,11)) W *7,!!,"ELIGIBILITY INFORMATION MISSING (NODE 11 IN 'PATIENT FILE') _ Transaction Cancelled" D ENDC G B0
;
;ELIGIBILITY STATUS
S ACHSELIG=$P($G(^AUPNPAT(DFN,11)),U,12)
I ACHSELIG'="C" W !!,*7,"Patient NOT ELIGIBLE for Contract Health Services",!,"Current status is: ",$S(ACHSELIG="I":"INELIGIBLE",ACHSELIG="D":"DIRECT ONLY",ACHSELIG="P":"PENDING VERIFICATION",1:"UNDEFINED") D ENDC G B0
;
;new code from jeanette. check for inactive or dead patients
I $P($G(^AUPNPAT(DFN,41,ACHSPATF,0)),U,5)="I" W !!,*7,"*****Patient is not registered as active*****",!!,"*****See Patient Regististration*****" D ENDC G B0
;I $P($G(^DPT(DFN,0)),U,10)'="" W !!,*7,"*****Patients record indicates a death date.*****",!!,"*****See Patient Registration.*****" D ENDC G B0
;
;
B5 ;EP - Enter Estimated DOS, 1 year either side of TODAY.
K DIR,ACHSOKFL
;Y2K -- BEGIN
;Y2K NORMALIZE THE DATES TO YYYYMMDD
;
;IF 'FISCAL YEAR'
I $P($G(^ACHSF(DUZ(2),0)),U,7)=1 S ACHSXXXX=(ACHSACFY-1)_$P($G(^ACHSF(DUZ(2),0)),U,6) S ACHSXXXZ=(ACHSACFY_$P($G(^ACHSF(DUZ(2),0)),U,6))-1 ;Y2000
;
I $P($G(^ACHSF(DUZ(2),0)),U,7)=0 S ACHSXXXX=ACHSACFY_$P($G(^ACHSF(DUZ(2),0)),U,6) S ACHSXXXZ=((ACHSACFY+1)_$P($G(^ACHSF(DUZ(2),0)),U,6))-1 ;Y2000
;
;Y2K -- END
B51 ;
W !!
S DIR(0)="D^::EX",DIR("A")="Enter Estimated Date of Service"
I $D(ACHSEDOS),ACHSEDOS]"" S DIR("B")=$$FMTE^XLFDT(ACHSEDOS)
D ^DIR
I $D(DUOUT)!$D(DTOUT) D END^ACHSA Q ;GO KILL VARS AND END
S (ACHSEDOS,ACHSZZZX)=Y
I $D(ACHSOKFL) S (ACHSCONP,ACHSCTNA,ACHSAGRN,ACHSAGRP)="" G B5A
W:Y<(DT-10000) *7,!," Date is more than ONE YEAR ago.",!
I Y>(DT+10000) W *7,!," Cannot be more than ONE YEAR in the future.",! G B51
;Y2K -- BEGIN
S ACHSZZZZ=17000000+ACHSZZZX ;Y2000
;Y2K -- END
I ACHSZZZZ<ACHSXXXX!(ACHSZZZZ>ACHSXXXZ) D G:ACHSOKFL=1 B51
. W *7,!!?15,$$REPEAT^XLFSTR("*",40)
. W !?15,"* Estimated DOS is NOT within the *",!?15,"* FISCAL YEAR you have selected. *",!?15,"* Press <RETURN> if OK. Or '^' to exit *",!?15,$$REPEAT^XLFSTR("*",40)
. S DIR("B")=$$FMTE^XLFDT(ACHSZZZX)
. S ACHSOKFL=1
;
;
S (ACHSCTNA,ACHSAGRN,ACHSAGRP,ACHSCONP)=""
B5A ;EP - Select provider/vendor.
S DIC("S")="I $P($G(^AUTTVNDR(Y,0)),U,5)=""""" ;CHECK 'INACTIVATED DATE'
S DIC="^AUTTVNDR(",DIC(0)="AEMQZ"
S DIC("A")="Select PROVIDER/VENDOR: "
I $G(ACHSPROV),$D(^AUTTVNDR(ACHSPROV,0)) S DIC("B")=$P($G(^AUTTVNDR(ACHSPROV,0)),U)
;
D ^DIC ;LOOKUP PROVIDER
;
K DIC
;
;IHS/SET/JVK ACHS*3.1*6 IF A FED SITE CHECK FOR COMPLETE EIN INFO
;S ACHSVFLG=""
;I $$PARM^ACHS(0,8)'="Y",Y>1,DT>3030901 D VCHK^ACHSVDVD
;
G B0:$D(DUOUT)
I $D(DTOUT) D END^ACHSA Q
I Y<1 W *7," Must Have Vendor" G B5A
;
;I ACHSVFLG W !,"You must fix the missing vendor entries listed above" G B5A ;IHS/SET/JVK ACHS*3.1*6
S ACHSPROV=+Y,ACHSCONP="",ACHSHON="",E=0,ACHSDFLG=2
;
D ^ACHSVDVD ;CHECK FOR DUPES WHEN ENTERING NEW VENDOR
;
G:'$G(ACHSPROV) B5A ;NO VENDOR FOUND TRY AGAIN
;
;
S X=$P($G(^AUTTVNDR(ACHSPROV,11)),U,3) ;VENDOR TYPE PTR
I +X<1 F W !,"Please enter 2-digit code for Vendor type.",! S DIE="^AUTTVNDR(",DA=ACHSPROV,DR=1103 D ^DIE K DIE G B5A:$D(Y) Q:$P($G(^AUTTVNDR(ACHSPROV,11)),U,3)
;
;ACHS*3.1*16 10/21/2009 OIT.IHS.FCJ ADDED NEXT LINE TO TEST FOR PARAMETER AND VENDOR CCR
I $$PARM^ACHS(0,15)="Y",(($P($G(^AUTTVNDR(ACHSPROV,0)),U,8)="N")!($P($G(^AUTTVNDR(ACHSPROV,0)),U,8)="")) W !,"Vendor is not CCR certified, please update vendor information.",! G B5A
;
PAN ; If HIGH VOLUME PROVIDER, prompt for Patient Account Number, optional.
I $D(^ACHSF(DUZ(2),18,"B",ACHSPROV)) S ACHSPAN=$$DIR^XBDIR("9002080.01,26.01","",$G(ACHSPAN))
;
D ^ACHSA3 ;ENTER DOCUMENTS (4/8) CON,DESC,PRD,ONUM
Q
;
;
ENDC ;
W !
D RTRN^ACHS
S DUOUT=""
K DFN
W @IOF
Q
;
NOCITY ; Cancel If No City or State for patient.
W *7,!!,"This patient does not have a complete mailing address",!,"in the medical records files."
W !!,"No document may be issued until the mailing address is complete.",!!!,"'",$P($G(^DD(9002080,14.04,0)),U),"' parameter = '",$$PARM^ACHS(2,4),"'.",!!
D RTRN^ACHS
S ACHSTYP=0
Q
;
PAWNEE ;
;IHS/ITSC/PMF 12/1/00 add this tag to accomodate a special
;Pawnee benefit. set var ACHSPWNE based on what happens
;
S DIC=1808000,DIC(0)="IQAZEM" S:$D(DFN) DIC("B")=$P($G(^DPT(DFN,0)),U)
D ^DIC K DIC
I $D(DUOUT)!(+Y<0) S ACHSPWNE="BACK" Q
S (ACHSDFN,DFN)=+Y,ACHSBPNO=$P($G(^AZOPBPP(+Y,0)),U,2)
K ACHSHRN,ACHSPATF
S PBEXDT=+$P($G(^AZOPBPP(+Y,0)),U,3),Y=PBEXDT X ^DD("DD")
;
;ACHS*3.1*4 3/28/02 pmf need to quit at the end of this if
;I PBEXDT<DT W !!,*7,"PBPP Eligibility Card Expired on ",Y," -- TRANSACTION CANCELLED" S ACHSPWNE="NOTOK" ; ACHS*3.1*4
I PBEXDT<DT W !!,*7,"PBPP Eligibility Card Expired on ",Y," -- TRANSACTION CANCELLED" S ACHSPWNE="NOTOK" Q ; ACHS*3.1*4
S ACHSPWNE="OK"
Q
;
ACHSA1 ; IHS/ITSC/PMF - ENTER DOCUMENTS (2/8)-(PT,HRN,FAC,EDOS,PRO) ; [ 09/22/2004 3:53 PM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,4,5,6,7,16**;JUNE 11, 2001
+2 ;ACHS*3.1*3 new method of display 'other resources'
+3 ;ACHS*3.1*4 fix bug in pawnee
+4 ;ACHS*3.1*5 12/06/2002 fix another pawnee bug
+5 ;ACHS*3.1*6 4/14/2003 Test vendor fields on Fed sites
+6 ;ACHS*3.1*7 9/8/2003-Comment out patch 6 items until AUT is ready
+7 ;ACHS*3.1*16 10/21/2009 IHS.OIT.FCJ Added test for Vendor CCR
+8 ;
+9 ;12/4/00 pmf add changes for pawnee special benefit
+10 ;
+11 ;pawnee change here
+12 IF +$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,10)=505613
Begin DoDot:1
+13 NEW ACHSPWNE
SET ACHSPWNE=0
+14 DO PAWNEE
+15 ; either go on, go to the end, or go back.
+16 ; if no value matches, go to the end.
+17 ;ACHS*3.1*5 098/26/2002 pmf tag name is wrong
+18 ;S TAG="END"
+19 SET TAG="ENDC"
+20 IF ACHSPWNE="OK"
SET TAG="B0C"
+21 IF ACHSPWNE="BACK"
SET TAG="A3^ACHSA"
+22 QUIT
End DoDot:1
GOTO @TAG
+23 ;
B0 ; Get patient name, if not Blanket or Spec. Trans.
+1 ;
+2 ;IF BLANKET FORM OR ????
IF $DATA(ACHSBLKF)!($DATA(ACHSSLOC))
GOTO B3
+3 ;GOTO PATIENT LOOKUP
IF '$DATA(DFN)!('$DATA(ACHSHRN))
GOTO B0B
+4 ;GOTO PATIENT LOOKUP
IF DFN&('$DATA(^DPT(DFN,0)))
GOTO B0B
+5 SET Y=DFN
+6 ;
+7 ;SET STANDARD PATIENT VARIABLES
DO ^AUPNPAT
+8 ;
+9 ;BEGIN Y2K FIX BLOCK
+10 WRITE !!,"Patient Info: ",$EXTRACT($PIECE($GET(^DPT(DFN,0)),U),U,22),?37,SEX,?39,$EXTRACT(DOB,4,5),"-",$EXTRACT(DOB,6,7),"-",$EXTRACT(DOB,1,3)+1700,?48,SSN,?60,$GET(ACHSHRN)
+11 ;END Y2K FIX BLOCK
+12 ;DID %RSE AND FOUND NOWHERE BUT HERE?????
IF $GET(ACHSREF(.03))
GOTO B0C
+13 ;
+14 ;PATIENT LOOKUP
B0B ;
+1 ;STANDARD CHS PATIENT LOOKUP
DO PTLK^ACHS
+2 KILL ACHSHRN,ACHSPATF
+3 ;KILL VARS AND QUIT
IF $DATA(DTOUT)
DO END^ACHSA
QUIT
+4 ;GO BACK TO CALLING RTN ACHSA
IF $DATA(DUOUT)!'$DATA(DFN)
QUIT
+5 SET Y=DFN
+6 ;
+7 ;POST PATIENT SELECTION VARIABLE SETS
DO ^AUPNPAT
+8 ;
B0C ;
+1 IF $GET(ACHSPATF)
IF $GET(ACHSHRN)
GOTO B4
+2 ;
+3 ;IF 'MULT. FACILITY PATIENT LOOKUP' IS NO SKIP TO CHECK ELIGIBILITY
+4 IF $$PARM^ACHS(2,5)'="Y"
SET ACHSPATF=DUZ(2)
SET ACHSHRN=$$HRN^ACHS(DFN,ACHSPATF)
GOTO B4
+5 ;
B1 ; Display/Select Facility(s) at which Patient is Registered.
+1 ;
+2 ;IF JUST ONE HRN THIS WILL GET IT ;'HEALTH RECORD NO.' NODE
+3 SET ACHS=0
+4 FOR ACHSPATF=0:0
IF '$ORDER(^AUPNPAT(DFN,41,ACHSPATF))
QUIT
Begin DoDot:1
+5 SET ACHSPATF=$ORDER(^AUPNPAT(DFN,41,ACHSPATF))
+6 SET ACHS=ACHS+1
End DoDot:1
+7 ;
+8 ;
+9 IF ACHS=0
WRITE !!,"NO CHARTS AVAILABLE!!"
GOTO B3
+10 IF ACHS=1
SET ACHSHRN=$$HRN^ACHS(DFN,ACHSPATF)
GOTO B4
+11 SET ACHS=0
+12 ;
+13 ;PRINT OUT THE LIST OF CHARTS AVAILABLE
+14 WRITE !!,"ITM #"," CHART #",?20,"FACILITY NAME",!
+15 FOR ACHSPATF=0:0
SET ACHSPATF=$ORDER(^AUPNPAT(DFN,41,ACHSPATF))
IF +ACHSPATF=0
QUIT
SET ACHS=ACHS+1
SET ACHSHRN=$PIECE($GET(^AUPNPAT(DFN,41,ACHSPATF,0)),U,2)
SET ACHS(ACHS)=ACHSPATF_U_ACHSHRN
WRITE !,$JUSTIFY(ACHS,4),?11,ACHSHRN,?20,$PIECE($GET(^DIC(4,ACHSPATF,0)),U)
+16 ;
B2 ;
+1 ;
+2 SET Y=$$DIR^XBDIR("N^1:"_ACHS,"SELECT ITEM # FOR APPROPRIATE FACILITY & CHART # COMBINATION","","","","",2)
+3 IF $DATA(DUOUT)
QUIT
+4 IF $DATA(DTOUT)
DO END^ACHSA
QUIT
+5 SET ACHSHRN=$PIECE(ACHS(+Y),U,2)
+6 SET ACHSPATF=$PIECE(ACHS(+Y),U)
+7 GOTO B4
+8 ;
B3 ;SECTION USED FOR ENTERING BLANKET DESCRIPTION
+1 ;
+2 ;ENTER DOCUMENT 3 OF 8
DO ^ACHSA2
+3 ;
+4 IF $DATA(DUOUT)!'$DATA(ACHSBLT)
DO A3^ACHSA
QUIT
+5 IF $GET(ACHSQUIT)
DO END^ACHSA
QUIT
+6 IF $DATA(ACHSBLKF)!($DATA(ACHSSLOC))
SET (ACHSPATF,ACHSHRN)=""
+7 ;
B4 ; Check CHS eligible.
+1 IF $DATA(ACHSBLKF)!($DATA(ACHSSLOC))
GOTO B5
+2 ;
+3 ;IF 'PATIENT ADDRESS REQUIRED'
+4 IF $$PARM^ACHS(2,4)'="N"
IF '$DATA(^DPT(DFN,.11))
GOTO NOCITY
IF $PIECE($GET(^DPT(DFN,.11)),U,4)=""!($PIECE($GET(^DPT(DFN,.11)),U,5)="")
GOTO NOCITY
+5 ;
+6 ;
+7 ;1/11/02 pmf rewrote ACHSRP31 as ACHSRPIN. new version is
+8 ;smaller, faster, cleaner, WORKS better, more modular, more
+9 ;usable, easier to read, better commented, and so on.
+10 ;S ACHSTAB=0 ; ACHS*3.1*3
+11 ;D EN^ACHSRP31 ;ACHS*3.1*3
+12 ; ACHS*3.1*3
DO GET^ACHSRPIN
DO PRT^ACHSRPIN
+13 ;K ACHSTAB ; ACHS*3.1*3
+14 ;
+15 ;
+16 ;IF 'CHECK FOR CHS ELIGIBILITY'
+17 IF $$PARM^ACHS(2,8)="N"
WRITE !!,"'",$PIECE($GET(^DD(9002080,14.08,0)),U),"' parameter = '",$$PARM^ACHS(2,8),"'.",!!,"CHS Eligibility not checked.",!,"Parameter 'CHECK FOR CHS ELIGIBILITY' not set."
GOTO B5
+18 ;
+19 ;
+20 IF '$DATA(^AUPNPAT(DFN,11))
WRITE *7,!!,"ELIGIBILITY INFORMATION MISSING (NODE 11 IN 'PATIENT FILE') _ Transaction Cancelled"
DO ENDC
GOTO B0
+21 ;
+22 ;ELIGIBILITY STATUS
+23 SET ACHSELIG=$PIECE($GET(^AUPNPAT(DFN,11)),U,12)
+24 IF ACHSELIG'="C"
WRITE !!,*7,"Patient NOT ELIGIBLE for Contract Health Services",!,"Current status is: ",$SELECT(ACHSELIG="I":"INELIGIBLE",ACHSELIG="D":"DIRECT ONLY",ACHSELIG="P":"PENDING VERIFICATION",1:"UNDEFINED")
DO ENDC
GOTO B0
+25 ;
+26 ;new code from jeanette. check for inactive or dead patients
+27 IF $PIECE($GET(^AUPNPAT(DFN,41,ACHSPATF,0)),U,5)="I"
WRITE !!,*7,"*****Patient is not registered as active*****",!!,"*****See Patient Regististration*****"
DO ENDC
GOTO B0
+28 ;I $P($G(^DPT(DFN,0)),U,10)'="" W !!,*7,"*****Patients record indicates a death date.*****",!!,"*****See Patient Registration.*****" D ENDC G B0
+29 ;
+30 ;
B5 ;EP - Enter Estimated DOS, 1 year either side of TODAY.
+1 KILL DIR,ACHSOKFL
+2 ;Y2K -- BEGIN
+3 ;Y2K NORMALIZE THE DATES TO YYYYMMDD
+4 ;
+5 ;IF 'FISCAL YEAR'
+6 ;Y2000
IF $PIECE($GET(^ACHSF(DUZ(2),0)),U,7)=1
SET ACHSXXXX=(ACHSACFY-1)_$PIECE($GET(^ACHSF(DUZ(2),0)),U,6)
SET ACHSXXXZ=(ACHSACFY_$PIECE($GET(^ACHSF(DUZ(2),0)),U,6))-1
+7 ;
+8 ;Y2000
IF $PIECE($GET(^ACHSF(DUZ(2),0)),U,7)=0
SET ACHSXXXX=ACHSACFY_$PIECE($GET(^ACHSF(DUZ(2),0)),U,6)
SET ACHSXXXZ=((ACHSACFY+1)_$PIECE($GET(^ACHSF(DUZ(2),0)),U,6))-1
+9 ;
+10 ;Y2K -- END
B51 ;
+1 WRITE !!
+2 SET DIR(0)="D^::EX"
SET DIR("A")="Enter Estimated Date of Service"
+3 IF $DATA(ACHSEDOS)
IF ACHSEDOS]""
SET DIR("B")=$$FMTE^XLFDT(ACHSEDOS)
+4 DO ^DIR
+5 ;GO KILL VARS AND END
IF $DATA(DUOUT)!$DATA(DTOUT)
DO END^ACHSA
QUIT
+6 SET (ACHSEDOS,ACHSZZZX)=Y
+7 IF $DATA(ACHSOKFL)
SET (ACHSCONP,ACHSCTNA,ACHSAGRN,ACHSAGRP)=""
GOTO B5A
+8 IF Y<(DT-10000)
WRITE *7,!," Date is more than ONE YEAR ago.",!
+9 IF Y>(DT+10000)
WRITE *7,!," Cannot be more than ONE YEAR in the future.",!
GOTO B51
+10 ;Y2K -- BEGIN
+11 ;Y2000
SET ACHSZZZZ=17000000+ACHSZZZX
+12 ;Y2K -- END
+13 IF ACHSZZZZ<ACHSXXXX!(ACHSZZZZ>ACHSXXXZ)
Begin DoDot:1
+14 WRITE *7,!!?15,$$REPEAT^XLFSTR("*",40)
+15 WRITE !?15,"* Estimated DOS is NOT within the *",!?15,"* FISCAL YEAR you have selected. *",!?15,"* Press <RETURN> if OK. Or '^' to exit *",!?15,$$REPEAT^XLFSTR("*",40)
+16 SET DIR("B")=$$FMTE^XLFDT(ACHSZZZX)
+17 SET ACHSOKFL=1
End DoDot:1
IF ACHSOKFL=1
GOTO B51
+18 ;
+19 ;
+20 SET (ACHSCTNA,ACHSAGRN,ACHSAGRP,ACHSCONP)=""
B5A ;EP - Select provider/vendor.
+1 ;CHECK 'INACTIVATED DATE'
SET DIC("S")="I $P($G(^AUTTVNDR(Y,0)),U,5)="""""
+2 SET DIC="^AUTTVNDR("
SET DIC(0)="AEMQZ"
+3 SET DIC("A")="Select PROVIDER/VENDOR: "
+4 IF $GET(ACHSPROV)
IF $DATA(^AUTTVNDR(ACHSPROV,0))
SET DIC("B")=$PIECE($GET(^AUTTVNDR(ACHSPROV,0)),U)
+5 ;
+6 ;LOOKUP PROVIDER
DO ^DIC
+7 ;
+8 KILL DIC
+9 ;
+10 ;IHS/SET/JVK ACHS*3.1*6 IF A FED SITE CHECK FOR COMPLETE EIN INFO
+11 ;S ACHSVFLG=""
+12 ;I $$PARM^ACHS(0,8)'="Y",Y>1,DT>3030901 D VCHK^ACHSVDVD
+13 ;
+14 IF $DATA(DUOUT)
GOTO B0
+15 IF $DATA(DTOUT)
DO END^ACHSA
QUIT
+16 IF Y<1
WRITE *7," Must Have Vendor"
GOTO B5A
+17 ;
+18 ;I ACHSVFLG W !,"You must fix the missing vendor entries listed above" G B5A ;IHS/SET/JVK ACHS*3.1*6
+19 SET ACHSPROV=+Y
SET ACHSCONP=""
SET ACHSHON=""
SET E=0
SET ACHSDFLG=2
+20 ;
+21 ;CHECK FOR DUPES WHEN ENTERING NEW VENDOR
DO ^ACHSVDVD
+22 ;
+23 ;NO VENDOR FOUND TRY AGAIN
IF '$GET(ACHSPROV)
GOTO B5A
+24 ;
+25 ;
+26 ;VENDOR TYPE PTR
SET X=$PIECE($GET(^AUTTVNDR(ACHSPROV,11)),U,3)
+27 IF +X<1
FOR
WRITE !,"Please enter 2-digit code for Vendor type.",!
SET DIE="^AUTTVNDR("
SET DA=ACHSPROV
SET DR=1103
DO ^DIE
KILL DIE
IF $DATA(Y)
GOTO B5A
IF $PIECE($GET(^AUTTVNDR(ACHSPROV,11)),U,3)
QUIT
+28 ;
+29 ;ACHS*3.1*16 10/21/2009 OIT.IHS.FCJ ADDED NEXT LINE TO TEST FOR PARAMETER AND VENDOR CCR
+30 IF $$PARM^ACHS(0,15)="Y"
IF (($PIECE($GET(^AUTTVNDR(ACHSPROV,0)),U,8)="N")!($PIECE($GET(^AUTTVNDR(ACHSPROV,0)),U,8)=""))
WRITE !,"Vendor is not CCR certified, please update vendor information.",!
GOTO B5A
+31 ;
PAN ; If HIGH VOLUME PROVIDER, prompt for Patient Account Number, optional.
+1 IF $DATA(^ACHSF(DUZ(2),18,"B",ACHSPROV))
SET ACHSPAN=$$DIR^XBDIR("9002080.01,26.01","",$GET(ACHSPAN))
+2 ;
+3 ;ENTER DOCUMENTS (4/8) CON,DESC,PRD,ONUM
DO ^ACHSA3
+4 QUIT
+5 ;
+6 ;
ENDC ;
+1 WRITE !
+2 DO RTRN^ACHS
+3 SET DUOUT=""
+4 KILL DFN
+5 WRITE @IOF
+6 QUIT
+7 ;
NOCITY ; Cancel If No City or State for patient.
+1 WRITE *7,!!,"This patient does not have a complete mailing address",!,"in the medical records files."
+2 WRITE !!,"No document may be issued until the mailing address is complete.",!!!,"'",$PIECE($GET(^DD(9002080,14.04,0)),U),"' parameter = '",$$PARM^ACHS(2,4),"'.",!!
+3 DO RTRN^ACHS
+4 SET ACHSTYP=0
+5 QUIT
+6 ;
PAWNEE ;
+1 ;IHS/ITSC/PMF 12/1/00 add this tag to accomodate a special
+2 ;Pawnee benefit. set var ACHSPWNE based on what happens
+3 ;
+4 SET DIC=1808000
SET DIC(0)="IQAZEM"
IF $DATA(DFN)
SET DIC("B")=$PIECE($GET(^DPT(DFN,0)),U)
+5 DO ^DIC
KILL DIC
+6 IF $DATA(DUOUT)!(+Y<0)
SET ACHSPWNE="BACK"
QUIT
+7 SET (ACHSDFN,DFN)=+Y
SET ACHSBPNO=$PIECE($GET(^AZOPBPP(+Y,0)),U,2)
+8 KILL ACHSHRN,ACHSPATF
+9 SET PBEXDT=+$PIECE($GET(^AZOPBPP(+Y,0)),U,3)
SET Y=PBEXDT
XECUTE ^DD("DD")
+10 ;
+11 ;ACHS*3.1*4 3/28/02 pmf need to quit at the end of this if
+12 ;I PBEXDT<DT W !!,*7,"PBPP Eligibility Card Expired on ",Y," -- TRANSACTION CANCELLED" S ACHSPWNE="NOTOK" ; ACHS*3.1*4
+13 ; ACHS*3.1*4
IF PBEXDT<DT
WRITE !!,*7,"PBPP Eligibility Card Expired on ",Y," -- TRANSACTION CANCELLED"
SET ACHSPWNE="NOTOK"
QUIT
+14 SET ACHSPWNE="OK"
+15 QUIT
+16 ;
