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

ACHSDFLK.m

Go to the documentation of this file. 
  1. ACHSDFLK ; IHS/ITSC/PMF - DEFERRAL LOOKUP ;  [ 04/19/2002  9:30 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18**;JUN 11, 2001
  1.  ;ACHS*3.1*4 whole routine is new for this patch
  1.  ;ACHS*3.1*18 4/1/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
  1.  ;
  1.  K ACHDLKER,DFN
  1.  S DIWL=5,DIWR=75,DIWF="W"
  1.  N DONE S DONE=0
  1.  ;
  1.  ;keep asking them for a deferral until we get DONE
  1.  ;DONE can mean we got one, or we are ready to quit
  1.  F  D  Q:DONE
  1.  . D GETDEF
  1.  . I $D(ACHDLKER) S DONE=1 Q
  1.  . I ACHSA="" S (ACHDLKER,DONE)=1 Q
  1.  . D PP
  1.  . Q
  1.  ;
  1.  K DIC
  1.  Q
  1.  ;
  1.  ;
  1. GETDEF ;get a deferral, either by number or by patient
  1.  W !!
  1.  K DFN,DIC,Y S ACHSA=""
  1.  ;{ABK, 3/31/10}S DIR("A")="Enter the DEFERRAL NUMBER or PATIENT"
  1.  ;{ABK, 3/31/10}S DIR("?")="Enter either the deferral number or a Patient Identifier (Name, HRN, SSN, DOB)"
  1.  S DIR("A")="Enter the UNMET NEED NUMBER or PATIENT"
  1.  S DIR("?")="Enter either the unmet need number or a Patient Identifier (Name, HRN, SSN, DOB)"
  1.  S DIR(0)="FO" D ^DIR K DIR
  1.  ;
  1.  ;now the responses.  if quit, quit.
  1.  Q:$D(DIRUT)
  1.  ;
  1.  ;see if the input is a real, full deferral case number
  1.  ;if so, X will not be null after this
  1.  S X="",X=$O(^ACHSDEF(DUZ(2),"D","B",Y,""))
  1.  ;
  1.  ;if they entered a blank space or a deferral number, use
  1.  ;^DIC to load info
  1.  I Y=" "!X S X="" D GETDEF2("EMZ",Y) Q:ACHSA'=""  W "  ","??" G GETDEF
  1.  ;
  1.  ;first, try patient lookup for registered patients
  1.  S X=Y,DIC="^AUPNPAT(",DIC(0)="EM",AUPNLK("ALL")=1
  1.  D ^DIC
  1.  ;
  1.  ;if that didn't work, try looking up unregistered patients
  1.  ;if it works, stop, if it doesn't go back to the top
  1.  I +Y<0 D  Q:ACHSA'=""  W "  ","??" G GETDEF
  1.  . D GETDEF2("EMZ",X)
  1.  . ;I +Y<1 S ACHDLKER="" G END
  1.  . ;S ACHSA=+Y
  1.  ;
  1.  ;if we DID find a registered patient, submit that and get deferral
  1.  S PATDAT=$G(^DPT(+Y,0))
  1.  I PATDAT="" G GETDEF
  1.  D GETDEF2("EMZ",$P(PATDAT,U,1))
  1.  I +Y<0 W "  ","??" G GETDEF
  1.  S ACHSA=+Y
  1.  ;
  1.  Q
  1.  ;
  1. GETDEF2(DIC0,X) ;
  1.  ;use ^DIC to get a deferral case.
  1.  ;input:   DIC0   the value to give DIC(0)
  1.  ;         X      the input value for ^DIC, not manditory
  1.  S X=$G(X)
  1.  K DIC
  1.  S DIC="^ACHSDEF("_DUZ(2)_",""D"","
  1.  S DIC(0)=DIC0
  1.  ;{ABK, 3/31/10}S DIC("A")="Enter the deferral NUMBER or PATIENT: "
  1.  S DIC("A")="Enter the unmet need NUMBER or PATIENT: "
  1.  S DIC("S")="I $P($G(^(0)),U)'[""#"""
  1.  S DA(1)=DUZ(2)
  1.  ;
  1.  ;3/28/02  pmf  experimenting with DIC("W")
  1.  S DIC("W")="W $E($P(^(0),U,2),4,5),""/"",$E($P(^(0),U,2),6,7),""/"",($E($P(^(0),U,2),1,3)+1700)"
  1.  ;
  1.  D ^DIC
  1.  Q:+Y<0
  1.  S ACHSA=+Y
  1.  Q
  1.  ;
  1. PP ;
  1.  S Y(0)=$G(Y(0))
  1.  G P0:$P(Y(0),U,5)'="Y"!($P(Y(0),U,6)']"")
  1.  G P0:'$D(^DPT($P(Y(0),U,6),0))
  1.  S DFN=$P(Y(0),U,6)
  1.  G P1
  1.  ;
  1. P0 ;
  1.  I $P(Y(0),U,7)="" G NAMERR
  1.  ;
  1. P1 ;
  1.  W !!,"You have chosen "_ACHDOCT_" document ",$P(Y(0),U),!!
  1.  G P2:'$D(DFN)
  1.  W $P($G(^DPT(DFN,0)),U),!
  1.  S A=$G(^DPT(DFN,.11))
  1.  W $P(A,U),!,$P(A,U,4)
  1.  S ACHDST=$P(A,U,5)
  1.  I ACHDST]"",$D(^DIC(5,ACHDST,0)) W " ",$P($G(^DIC(5,ACHDST,0)),U,2)
  1.  W " ",$P(A,U,6),!!
  1.  G P3
  1.  ;
  1. P2 ;
  1.  S A=$G(^ACHSDEF(DUZ(2),"D",ACHSA,10))
  1.  W $P(A,U),!,$P(A,U,2),!,$P(A,U,3)
  1.  S ACHDST=$P(A,U,4)
  1.  I ACHDST]"",$D(^DIC(5,ACHDST,0)) W " ",$P($G(^DIC(5,ACHDST,0)),U,2)
  1.  W " ",$P(A,U,5),!!
  1. P3 ;
  1.  W "Date of service ",$$FMTE^XLFDT($$DN^ACHS(0,4)),!!
  1.  S %=$$DIR^ACHS("Y","Is this correct","YES","Did you select the correct document?","",2)
  1.  I $D(DTOUT)!$D(DUOUT) S ACHDLKER="",DONE=1
  1.  I % S DONE=1
  1.  Q
  1.  ;
  1. NAMERR ;
  1.  W !!,*7,"No valid PATIENT NAME in this file.",!,"No letter may be printed until a valid patient is entered.",!!
  1.  Q
  1.  ;