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

ACHSA1.m

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