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

ACHSDF1.m

Go to the documentation of this file. 
  1. ACHSDF1 ; IHS/ITSC/PMF - UNMET NEEDS DATA ENTRY 2/2 ; [ 12/06/2002  10:36 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18**;JUN 11, 2001
  1.  ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Remove non-standard error recording.
  1.  ;ACHS*3.1*18 6/30/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
  1.  ;
  1. NUMBER ;EP
  1.  ;
  1.  N ACHDDNUM,ACHDDOS,ACHDFY,ACHDMSG,ACHDQTR,ACHDSEQ
  1.  ;
  1.  S ACHDDOS=$$DF^ACHS(0,2)
  1.  S ACHDFY=$$GETFY^ACHSDN(ACHDDOS)
  1.  S ACHDQTR=+$E($P($$FY^ACHS(ACHDFY),U),4,5)
  1.  ;
  1.  ;
  1.  S Y=0
  1.  F X=ACHDQTR:1 S:X=13 X=1 S Y=Y+1 I X=+$E(ACHDDOS,4,5) Q
  1.  S ACHDQTR=$S(Y<4:1,Y<7:2,Y<10:3,1:4)
  1.  S ACHDFY=$S(ACHDFY>50:"19",1:"20")_ACHDFY
  1.  ;
  1.  ;SET THE ZERO NODE OF THE 'SEQUENCE NUMBER BY FISCAL YEAR' SUBFILE 
  1.  I '$D(^ACHSDEF(DUZ(2),1,0)) S ^ACHSDEF(DUZ(2),1,0)=$$ZEROTH^ACHS(9002066,.02)
  1.  I '$D(^ACHSDEF(DUZ(2),1,ACHDFY,0)) S DIC="^ACHSDEF("_DUZ(2)_",1,",DIC(0)="L",(DINUM,X)=ACHDFY K DD,DO D FILE^DICN Q:+Y<1
  1.  S ACHDMSG=0
  1.  I '$$LOCK^ACHS("^ACHSDEF(DUZ(2),1)","+") Q
  1.  ;
  1. SEQ ;
  1.  S ACHDSEQ=+$P($G(^ACHSDEF(DUZ(2),1,ACHDFY,0)),U,2)+1
  1.  S $P(^ACHSDEF(DUZ(2),1,ACHDFY,0),U,2)=ACHDSEQ
  1.  S ACHDDNUM="D"_$E(ACHDFY,4)_ACHDQTR_"-"_ACHD("AREA")_ACHD("FAC")_"-"_ACHDSEQ
  1.  I $D(^ACHSDEF(DUZ(2),"D","B",ACHDDNUM)) S ACHDMSG=ACHDMSG+1 W:ACHDMSG<2 !!,"*** one moment, please ***",!! G SEQ
  1.  I '$$LOCK^ACHS("^ACHSDEF(DUZ(2),1)","-") Q
  1.  ;
  1.  ;ENTER DOCUMENT NUMBER
  1.  I '$$DIE^ACHSDF(".01///"_ACHDDNUM) Q
  1.  ;{ABK,6/30/10}W !!,"This DEFERRED SERVICE has been posted.  The DOCUMENT NUMBER is: ",ACHDDNUM,!!!!
  1.  W !!,"This UNMET NEED has been posted.  The DOCUMENT NUMBER is: ",ACHDDNUM,!!!!
  1.  D RTRN^ACHS
  1.  Q
  1.  ;
  1. SETCK ;EP - Remove INCOMPLETE DEFERRED AND DENIAL  DOCUMENTS AND CHECK SITE PARAMETERS.
  1.  S ACHD="#"
  1.  F  S ACHD=$O(^ACHSDEF(DUZ(2),"D","B",ACHD)) Q:ACHD=""!(ACHD'["#")!($P(ACHD,"#",2)=$P($H,","))  D
  1.  . S ACHDX=0
  1.  . F  S ACHDX=$O(^ACHSDEF(DUZ(2),"D","B",ACHD,ACHDX)) Q:+ACHDX=0  S DIK="^ACHSDEF("_DUZ(2)_",""D"",",DA(1)=DUZ(2),DA=ACHDX D ^DIK W "."
  1.  ;
  1.  ;
  1.  ;REMOVE INCOMPLETE DENIAL DOCUMENTS
  1.  K DA,DIK
  1.  S ACHD="#"
  1.  F  S ACHD=$O(^ACHSDEN(DUZ(2),"D","B",ACHD)) Q:ACHD=""!(ACHD'["#")!($P(ACHD,"#",2)=$P($H,","))  D
  1.  .;
  1.  .;
  1.  . S ACHDX=0
  1.  . F  S ACHDX=$O(^ACHSDEN(DUZ(2),"D","B",ACHD,ACHDX)) Q:+ACHDX=0  S DIK="^ACHSDEN("_DUZ(2)_",""D"",",DA(1)=DUZ(2),DA=ACHDX D ^DIK W "."
  1.  .Q
  1.  ;
  1.  ;CHECK SITE PARAMTERS
  1.  K ACHDX,ACHD("NOTSET"),ACHDXQT,DA,DIK
  1.  ;
  1.  I '$D(^ACHSDENR(DUZ(2),0)) D NOTSET("No 0 NODE IN 'CHS DENIAL FACILITY' file '$D(^ACHSDENR("_DUZ(2)_",0))") Q
  1.  ;
  1.  I '$L($P($G(^ACHSDENR(DUZ(2),0)),U,2)) D
  1.  . N ACHSSTR
  1.  . S ACHSSTR="'FACILITY ABBREVIATION' not entered in 'CHS DENIAL FACILITY' file "
  1.  . S ACHSSTR=ACHSSTR_$P($G(^ACHSDENR(DUZ(2),0)),U,2)
  1.  . ;{ABK,6/30/10}. S ACHSSTR=ACHSSTR_". Try editing this file via Fileman or use the 'Parameters' option in the CHS Denial/Deferred Services menu"
  1.  . S ACHSSTR=ACHSSTR_". Try editing this file via Fileman or use the 'Parameters' option in the CHS Denial/Unmet Needs menu"
  1.  . D NOTSET(ACHSSTR)
  1.  . Q
  1.  ;
  1.  I '$P($G(^AUTTLOC(DUZ(2),0)),U,4) D NOTSET("'AREA' entry missing in 'LOCATION' file $P($G(^AUTTLOC("_DUZ(2)_",0)),U,4)") Q
  1.  ;
  1.  I '$D(^ACHSDENR(DUZ(2),100)) D NOTSET("No 'SERVICE UNIT DIRECTOR' info in 'CHS DENIAL FACILITY' File '$D(^ACHSDENR("_DUZ(2)_",100)) (Use 'Parameters' option).") Q
  1.  ;
  1.  I '$D(^ACHSDENR(DUZ(2),200)) D NOTSET("No 'AREA DIRECTOR' info in 'CHS DENIAL FACILITY' File '$D(^ACHSDENR("_DUZ(2)_",200)) (Use 'Parameters' option).") Q
  1.  ;
  1.  I '$D(^AUTTAREA($P($G(^AUTTLOC(DUZ(2),0)),U,4),0)) D NOTSET("No entry in 'AREA' file for '$D(^AUTTAREA($P($G(^AUTTLOC("_DUZ(2)_",0)),U,4),0)") Q
  1.  ;
  1.  ;
  1.  I $P($G(^AUTTAREA($P($G(^AUTTLOC(DUZ(2),0)),U,4),0)),U,3)="" D NOTSET("No 'PREFIX/REGION' in 'AREA' file for $P($G(^AUTTAREA($P($G(^AUTTLOC("_DUZ(2)_",0)),U,4),0)),U,3)") Q
  1.  ;
  1.  S ACHD("AREA")=$P($G(^AUTTAREA($P($G(^AUTTLOC(DUZ(2),0)),U,4),0)),U,3)
  1.  S ACHD("FAC")=$P($G(^ACHSDENR(DUZ(2),0)),U,2)
  1.  Q
  1.  ;
  1. NOTSET(ACHSMSG) ;
  1.  D VIDEO^ACHS
  1.  W !!,*7,"The " W:$D(IORVON) IORVON W "DENIAL" W:$D(IORVOFF) IORVOFF W " parameters for this site have "
  1.  W:$D(IORVON) IORVON W "not been properly set." W:$D(IORVOFF) IORVOFF
  1.  W !!,$$C^ACHS(ACHSMSG)
  1.  W !!,"Print this screen to a printer."
  1.  W *7,!!,$G(IOBON),$G(IORVON),"Contact your site manager immediately!",$G(IOBOFF),$G(IORVOFF),!!
  1.  ;S ^ACHSERR($H)=ACHSMSG;SET ERROR MESSAGE;IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1.  ;D CLEAN^ACHS("");CLEAN UP ^ACHSERR GLOBAL;IHS/SET/GTH ACHS*3.1*5 12/06/2002
  1.  D RTRN^ACHS
  1.  S ACHD("NOTSET")="",ACHDXQT=1
  1.  Q
  1.  ;