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

ACHSDF.m

Go to the documentation of this file. 
  1. ACHSDF ; IHS/ITSC/PMF - UNMET NEEDS DATA ENTRY (1/2) ;   [ 03/24/2005  8:22 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18**;JUN 11, 2001;Build 43
  1.  ;ACHS*3.1*18 4/1/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
  1.  ;
  1.  D SETCK^ACHSDF1       ;SET UP SITE PARAMETERS
  1.  Q:$G(ACHDXQT)
  1. START ; --- Set Temporary Number.
  1.  I $D(^ACHSDEF(DUZ(2),"D",0))=0 S ^ACHSDEF(DUZ(2),"D",0)="^9002066.01A^0^0"
  1.  S DIC="^ACHSDEF("_DUZ(2)_",""D"","
  1.  S DA(1)=DUZ(2)
  1.  S DIC(0)="L"
  1.  S X="#"_$P($H,",",1)_"#"_$P($H,",",2)
  1.  D ^DIC
  1.  I +Y<1 S ACHDXIT="" D END Q
  1.  S ACHSA=+Y
  1.  ;
  1.  ;FORCE ENTER 'DATE OF SERVICE' AND 'ISSUED BY'
  1.  I '$$DIE("2////"_DT_";3////"_DUZ,2) S ACHDXIT="" D END Q
  1.  D PAT
  1.  Q:X[U
  1.  D END
  1.  Q
  1.  ;
  1. PAT ; --- Is Patient Registered.
  1.  K DQ
  1.  Q:'$$DIE("5//Y",2)
  1.  I $D(Y) S ACHDXIT="" Q
  1.  I $$DF^ACHS(0,5)="N" G PATNOT
  1.  ;
  1.  ;ITSC/SET/JVK ACHS*3.1*12 ADD CHANGES FOR IHS/OKCAO/POC PAWNEE BEN PKG
  1.  ;Q:'$$DIE(6,2)
  1.  ;I +$P($G(^AUTTLOC(DUZ(2),0)),U,10)=505613 Q:'$$DIEPWN ;ACHS*3.1*18 3.12.2010 IHS.OIT.FCJ ADDED ACHSDXIT TST
  1.  I +$P($G(^AUTTLOC(DUZ(2),0)),U,10)=505613 Q:('$$DIEPWN)!(ACHDXIT) Q
  1.  E  Q:'$$DIE(6,2)
  1.  ;ITSC/SET/JVK END CHANGES ACHS*3.1*12
  1.  I $D(Y) S ACHDXIT="" Q
  1.  I '$$DF^ACHS(0,6) W !,*7,"A Patient Name Must Be Entered",!! G PAT
  1.  D USER
  1.  Q
  1.  ;
  1. PATNOT ; --- Patient not on file.
  1.  K DQ
  1.  Q:'$$DIE("7:13")
  1.  I $D(Y) G PAT
  1.  I '$L($$DF^ACHS(0,7)) W !,*7,"A Patient Name Must Be Entered",!! G PAT
  1.  D USER
  1.  Q
  1.  ;
  1. USER ; --- Set variables to file.
  1.  Q:'$$DIE("3////"_DUZ)
  1.  I $D(Y) S ACHDXIT="" Q
  1.  D ISSDT
  1.  Q
  1.  ;
  1. ISSDT ; --- Issue Date.
  1.  Q:'$$DIE("2////"_DT)
  1.  I $D(Y) S ACHDXIT="" Q
  1.  D REQ
  1.  Q
  1.  ;
  1. REQ ; --- Date Request Received.
  1.  Q:'$$DIE(4,2)
  1.  I $D(Y) S ACHDXIT="" Q
  1.  I '$$DF^ACHS(0,4) W !,*7,"A Date Received Request Must Be Entered" G REQ
  1.  D DEFCAT
  1.  Q
  1.  ;
  1. DEFCAT ; --- Deferred Service Category.
  1.  W !!
  1.  ;{ABK,7/9/10}S DIC="^ACHSDFC(",DIC(0)="QAEM",DIC("A")="Enter Deferred Service Category: "
  1.  S DIC="^ACHSDFC(",DIC(0)="QAEM",DIC("A")="Enter Unmet Need Category: "
  1.  D ^DIC
  1.  I X=U Q
  1.  ;{ABK,7/9/10}I Y<0 W *7,!!,"Must Have Deferred Services Category",! G DEFCAT
  1.  I Y<0 W *7,!!,"Must Have Unmet Need Category",! G DEFCAT
  1.  S ACHDCAT=+Y
  1.  Q:'$$DIE("100////"_ACHDCAT)
  1.  ;
  1. DEFSUB ; --- Deferred Service Subcategory
  1.  W !!
  1.  ;{ABK,7/9/10}S DIC="^ACHSDFC("_ACHDCAT_",1,",DIC(0)="AQEM",DIC("A")="Enter Deferred Service Subcategory: "
  1.  S DIC="^ACHSDFC("_ACHDCAT_",1,",DIC(0)="AQEM",DIC("A")="Enter Unmet Need Subcategory: "
  1.  D ^DIC
  1.  I X=U Q
  1.  ;{ABK,7/9/10}I Y<0 W *7,!!,"Must Have Deferred Service Subcategory",! G DEFSUB
  1.  I Y<0 W *7,!!,"Must Have Unmet Need Subcategory",! G DEFSUB
  1.  S ACHDSUB=+Y
  1.  Q:'$$DIE("105////"_ACHDSUB)
  1.  Q:'$$DIE("110:130",2)
  1.  I $D(Y) G DEFCAT
  1.  D DEFDIAG
  1.  Q
  1.  ;
  1. DEFDIAG ; --- Deferred Service Diagnosis.
  1.  I $$DF^ACHS(100,2)="O" G DEFPROC
  1.  Q:'$$DIE(200,2)
  1.  I $D(Y) S ACHDXIT="" Q
  1.  ;ACHS*3.1*23 CHG ICD9 TO ICD IN NXT LINE
  1.  I '$D(^ACHSDEF(DUZ(2),"D",ACHSA,200,0)) W !,*7,"An ICD Diagnosis Code Must Be Entered",!! G DEFDIAG
  1.  D DEFCMT
  1.  Q
  1.  ;
  1. DEFPROC ; --- Deferred Service CPT.
  1.  Q:'$$DIE(300,2)
  1.  I $D(Y) S ACHDXIT="" Q
  1.  I '$D(^ACHSDEF(DUZ(2),"D",ACHSA,300,0)) W !,*7,"A CPT Procedure Code Must Be Entered",!! G DEFPROC
  1.  D DEFCMT
  1.  Q
  1.  ;
  1. DEFCMT ; --- Comment. 
  1.  Q:'$$DIE(400,2)
  1.  I $D(Y) S ACHDXIT="" Q
  1.  D DEFDCT
  1.  Q
  1.  ;
  1. DEFDCT ; --- Document Control.
  1.  W !!
  1.  K DIR
  1.  S DIR(0)="Y",DIR("A")="Enter Document Control Information Now",DIR("B")="NO"
  1.  S DIR("?",1)="Answer 'Y' if patient or their representative is picking up the document in person.",DIR("?")="Answer 'N' if document is being mailed."
  1.  D ^DIR
  1.  I Y Q:'$$DIE("500////Y;501:503",2)  I $D(Y) S ACHDXIT="" Q
  1.  Q
  1.  ;
  1.  ;EP - Denial Issued.
  1.  Q:'$$DIE("504:505",2)
  1.  I $D(Y) S ACHDXIT="" D END Q
  1.  Q
  1.  ;
  1. DEFPO ; --- Service Provided on PO.
  1.  Q:'$$DIE("506:507",2)
  1.  I $D(Y) S ACHDXIT="" Q
  1.  Q
  1.  ;
  1. END ;
  1.  D:'$D(ACHDXIT) ^ACHSDFDP                    ;DISPLAY DOCUMENT INFO
  1.  ;                                            IF NO EXIT THEN
  1.  I '$D(ACHDXIT),'$D(DUOUT) D NUMBER^ACHSDF1   ;SET THE DEFERRED SERVICE
  1.  ;                                            NUMBER AND POST THE
  1.  ;                                            DOCUMENT 
  1.  K ACHDXIT
  1.  Q
  1.  ;
  1. DOCNTL1 ;EP - CALLED FROM OPTION 'ACHS DEF DOCNTL' Enter Document Control Info
  1.  D SETCK^ACHSDF1                   ;CLEAR PHONY DOCUMENTS
  1.  N ACHSA,DA,DIC,DIE
  1.  W !!
  1.  S DIC="^ACHSDEF("_DUZ(2)_",""D"",",DA(1)=DUZ(2),DIC(0)="AQEM"
  1.  D ^DIC
  1.  Q:Y<1
  1.  S ACHSA=+Y
  1.  I $$DIE("500////Y;501:503",2)
  1.  Q
  1.  ;
  1. DENIAL ;EP - CALLED FROM OPTION 'ACHS DEN INFO' Enter Denial Info
  1.  D SETCK^ACHSDF1                ;CLEAR PHONY DOCUMENTS
  1.  N ACHSA,DA,DIC,DIE
  1.  W !!
  1.  S DIC="^ACHSDEF("_DUZ(2)_",""D"",",DA(1)=DUZ(2),DIC(0)="AQEM"
  1.  D ^DIC
  1.  Q:Y<1
  1.  S ACHSA=+Y
  1.  I $$DIE("504;505",2)
  1.  Q
  1.  ;
  1. PO ;EP - CALLED FROM OPTION 'ACHS DEF PO' Enter Purchase Order Info
  1.  D SETCK^ACHSDF1                 ;CLEAR PHONY DOCUMENTS
  1.  N ACHSA,DA,DIC,DIE
  1.  W !!
  1.  S DIC="^ACHSDEF("_DUZ(2)_",""D"",",DA(1)=DUZ(2),DIC(0)="AEQM"
  1.  D ^DIC
  1.  Q:Y<1
  1.  S ACHSA=+Y
  1.  I $$DIE("506;507",2)
  1.  Q
  1.  ;
  1. DIE(DR,Z) ;EP --- Edit Deferred Service
  1.  I $G(Z) F %=1:1:Z W !
  1.  S DIE="^ACHSDEF("_DUZ(2)_",""D"","
  1.  S DA(1)=DUZ(2)
  1.  S DA=ACHSA
  1.  S AUPNLK("INAC")=""
  1.  S ACHDALL=1
  1.  ;S DIC("S")="I $D(^AUPNPAT(Y,41,DUZ(2)))"
  1.  ;
  1.  ;S DIC("W")="I $D(^AUPNPAT(Y,41,DUZ(2)))"
  1.  ;
  1.  I '$$LOCK^ACHS("^ACHSDEF(DUZ(2),""D"",ACHSA)","+") S DUOUT="" Q 0
  1.  D ^DIE I $D(Y) S ACHDXIT=""
  1.  I '$$LOCK^ACHS("^ACHSDEF(DUZ(2),""D"",ACHSA)","-") S DUOUT="" Q 0
  1.  Q 1
  1.  ;
  1. DIEPWN() ;ITSC/SET/JVK ADD FOR ACHS*3.1*12 IHS/OKCAO/POC PAWNEE BEN PKG
  1.  N PBEXDT,DFN,DUZSAVE
  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)!($D(DTOUT))!(+Y<0) Q 0
  1.  S DFN=+Y
  1.  ;ACHS*3.1*15 1.26.2009 IHS/OIT/FCJ ADDED $ IN FRONT OF THE P($G TO THE NEXT LINE
  1.  S PBEXDT=+$P($G(^AZOPBPP(+Y,0)),U,3),Y=PBEXDT X ^DD("DD")
  1.  I PBEXDT<DT W !!,*7,"PBPP Eligibility Card Expired on ",Y Q 0
  1.  F %=1:1:2 W !
  1.  S DIE="ACHSDEF("_DUZ(2)_",""D"","
  1.  S DA(1)=DUZ(2)
  1.  S DA=ACHSA
  1.  S AUPNLK("INAC")=""
  1.  S DUZSAVE=DUZ(2),DUZ(2)=0
  1.  S ACHDALL=1
  1.  I '$$LOCK^ACHS("^ACHSDEF(DUZ(2),""D"",ACHSA)","+") S DUOUT="" Q 0
  1.  S DFN="`"_DFN
  1.  S DR="6///^S X=DFN" D DIE I $D(Y) S ACHDXIT=""
  1.  S DUZ(2)=DUZSAVE
  1.  I '$$LOCK^ACHS("^ACHSDEF(DUZ(2),""D"",ACHSA)","-") S DUOUT="" Q 0
  1.  Q 1