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

ACHSDA.m

Go to the documentation of this file. 
  1. ACHSDA ; IHS/ITSC/PMF - PATIENT DATA ;     [ 10/16/2001   8:16 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
  1.  ;OCAO/IHS CL
  1.  ;VERSION;1.31;5/1/88
  1.  ;
  1.  I '$D(^AZOPBPP) W !!,"This Option Not Yet Available",!! H 2 G END
  1. L0 ;
  1.  S ACHSYAYA=U_"AZO"_"PWN"_"LK" D @ACHSYAYA K ACHSYAYA G END:'$D(DFN) ; LINE ADDED TO DO PAWNEE BENEFIT/DLW/6/30/95
  1.  ;
  1. L1 ;
  1.  S DA=DFN,DIE="^AZOPBPP(",DR=".01:99" D ^DIE
  1.  G L0
  1.  ;
  1. END ;
  1.  Q
  1.  ;
  1. SBRS ;
  1.  ;IHS/ITSC/PMF  1/19/01  changes in this module to comply
  1.  ;with SAC.  the READ command in the comment is in quotes so
  1.  ;that SAC checker does not see it.  Yes, it looks in comments
  1.  ;K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT "R" Y:DTIME I '$T W *7 "R" Y:5 G SBRS:Y="." I '$T S (DTOUT,Y)="" Q
  1.  K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT
  1.  S DIR(0)="F"
  1.  D ^DIR
  1.  ;
  1.  ;S:Y="" DLOUT="" S:Y="/.," (DFOUT,Y)="" S:Y="^" (DUOUT,Y)="" S:Y?1"?".E!(Y["^") (DQOUT,Y)=""
  1.  I Y="" S DLOUT="" Q
  1.  I Y="/.," S (DFOUT,Y)="" Q
  1.  I Y="^" S (DUOUT,Y)=""
  1.  I (Y?1"?".E!(Y["^")) S (DQOUT,Y)="" Q
  1.  I Y'?1N W " Must be a number" G SBRS
  1.  I Y<1!(Y>3) W " Must be between 1 and 3" G SBRS
  1.  Q
  1.  ;
  1. ADD ;ADD A NEW PATIENT TO THE PB FILE
  1.  ;IHS/ITSC/PMF  1/8/01  replace this old fashioned call with
  1.  ;a call to the approved routine  {D AUCLS}
  1.  ;clear the screen
  1.  D ^XBCLS
  1.  ;
  1. A ;
  1.  ;IHS/ITSC/PMF  1/9/01  change call from old routine to new
  1.  ;but identical ^XB routine.  also, any more than three dots
  1.  ;in row is gratuitous
  1.  ;W !!,"ADDING a patient to the PAWNEE BENEFIT package files.....",!!! {D AUALLLK} G END:'$D(DFN)
  1.  W !!,"ADDING a patient to the PAWNEE BENEFIT package files...",!!! D ^XBALLLK G END:'$D(DFN)
  1.  ;
  1. A1 ;
  1.  I $D(^AZOPBPP(DFN)) W !!,*7,"This patient is already enrolled in the Benefit Package.",!!,"BENEFIT PACKAGE NUMBER: ",$P($G(^(DFN,0)),U,2),!! G A
  1. A2 ;
  1.  ;IHS/ITSC/PMF  1/10/01  split next line and replace naked refs
  1.  ;G B:$D(^AUPNPAT(DFN,41,2564))!$D(^(2565))!$D(^(2566)) W !!,*7,"The patient must be registered at Pawnee, Pawhuska, or White Eagle",!,"before he/she can be added to the Benefit Package file.",!! G A
  1.  G B:$D(^AUPNPAT(DFN,41,2564))!$D(^AUPNPAT(DFN,41,2565))!$D(^AUPNPAT(DFN,41,2566))
  1.  W !!,*7,"The patient must be registered at Pawnee, Pawhuska, or White Eagle",!,"before he/she can be added to the Benefit Package file.",!! G A
  1.  ;
  1. B ;
  1.  W !! S DIE="^AZOPBPP(",DA=DFN,DR=".01:99",^AZOPBPP(DFN,0)=DFN,^AZOPBPP("B",DFN,DFN)="",$P(^AZOPBPP(0),U,3)=DFN,$P(^(0),"^",4)=+$P(^(0),"^",4)+1 D ^DIE
  1.  ;
  1. C ;CHECK FOR BEN. PACK. NUMBER
  1. C1 ;
  1.  I $D(^AZOPBPP(DFN,0)),$P(^AZOPBPP(DFN,0),"^",2)']"" S DR=".01///@" D ^DIE W !!,*7,"File deleted - no Benefit Package number.",!! G A
  1.  G END
  1. TEMP ;ADD NEW PATIENT WITH TEMPORART CHART NUMBER
  1.  W !!,"At which facility will this patient be registered?",!!?10,"1...Pawnee",!?10,"2...White Eagle",!?10,"3...Pawhuska",!!,?10 D SBRS Q:$D(DTOUT)!$D(DFOUT)!$D(DUOUT)!$D(DLOUT)
  1. QUES I $D(DQOUT) W !!,"Choose the facility in which this patient will receive his primary care.",!! G TEMP
  1.  S Y=+Y I Y<1!(Y>3) S DQOUT="" G QUES
  1.  S ^ACHS("ASITE")=ASITE,ASITE=$S(Y=3:2564,Y=2:2565,1:2566)
  1.  S DOG="" D DOG^AG0 D L2^AG2:$D(DFN) K DFN,DOG,%DT S ASITE=$G(^ACHS("ASITE")) K ^ACHS("ASITE") G END