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

BCHEGP1.m

Go to the documentation of this file. 
  1. BCHEGP1 ; IHS/CMI/LAB - GROUP FORM DATA ENTRY CREATE RECORD ; 
  1.  ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
  1.  ;
  1.  ;PATCH #16 Populates all Travel Time to one patient
  1.  ;rather than deviding among all pts in group
  1.  ;
  1.  ;loop and get patients until BCHNUM
  1. START ;EP - called from BCHLEGP
  1.  S (BCHQUIT,BCHHIT)=0
  1. START1 ;
  1.  F BCHLEGPI=1:1 D PROCESS Q:$G(BCHQUIT)  Q:BCHHIT=BCHNUM
  1.  I BCHNUM'=BCHHIT D ERROR I 'BCHSTOP G START1
  1.  D EXIT
  1.  Q
  1. PROCESS ;
  1.  S DFN="",BCHNRPAT=""
  1.  D GETPAT
  1.  Q
  1. GETPAT ;
  1.  W !
  1.  ;W:$D(IOF) @IOF
  1.  W !!?15,"******   P A T I E N T   I N F O R M A T I O N   ******",!!
  1.  W !,"If this encounter involved a particular patient, please enter the patient's",!,"chart # or name now.  If this is not a single patient encounter,",!,"but a group encounter, simply HIT the RETURN key to continue.",!
  1.  W !,"Please enter the patient information now.",!
  1.  S DFN=""
  1.  S DIR(0)="FO^1:30",DIR("A")="Enter PATIENT NAME or CHART #"
  1.  S DIR("?",1)="     To find a patient, you can enter the patient's chart number;"
  1.  S DIR("?",2)="     lastname,firstname; SSN; or DOB."
  1.  S DIR("?",3)=" "
  1.  S DIR("?",4)="     If the patient cannot be found in the Patient Registration"
  1.  S DIR("?",5)="     database and you would like to capture demographic information"
  1.  S DIR("?",6)="     for this patient into the CHR database, answer NO when asked"
  1.  S DIR("?",7)="     if you would like to try another lookup.  You will then be"
  1.  S DIR("?",8)="     given the opportunity to capture the patient's demographic"
  1.  S DIR("?",9)="     data on the following screen."
  1.  S DIR("?",10)=""
  1.  S DIR("?",11)="     Registered patient demographic data can only be edit via the"
  1.  S DIR("?")="     Patient Registration system."
  1.  W !,"So far you have entered ",BCHHIT," patient records out of a total of ",BCHNUM,".",!
  1.  I BCHHIT W "You have entered records for: " D  W !!
  1.  .S X=0 F  S X=$O(^BCHGROUP(BCHFID,21,X)) Q:X'=+X  W !?5,$P($G(^BCHR(X,11)),U)
  1.  D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I Y="" W !!,"No patient entered!! - Required",! G GETPAT
  1.  I $D(DIRUT) W !,"No patient entered!! - Required." S BCHQUIT=1 Q
  1.  S (X,BCHNAME)=Y,DIC="^AUPNPAT(",DIC(0)="MQE" D ^DIC K DIC
  1.  I Y=-1 D NOREG Q
  1.  W !?25,"Ok" S %=1 D YN^DICN I %'=1 W !!,"Try again.",! G GETPAT
  1.  S DFN=+Y
  1.  D GENREC
  1.  Q
  1.  ;
  1. NOREG ;
  1.  S DFN=""
  1.  K BCHAGAIN
  1.  W !,"That patient cannot be found in the Registration database."
  1.  W ! S DIR(0)="Y",DIR("A")="Do you want to try to lookup the patient in registration again",DIR("B")="Y" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I $D(DIRUT) W !,"Exiting..." S BCHQUIT=1 Q
  1.  I Y G GETPAT
  1.  W !!,"Please select a patient from the Non-Registered Patient Database",!,"or enter a new Non-Registered Patient.",!
  1.  S DIC="^BCHRPAT(",DIC(0)="AEMQL" D ^DIC K DIC
  1.  ;SCREENMAN CALL
  1.  ;S DIE="^BCHR(",DA=BCHR,DR="1101///"_BCHNAME D ^DIE K DIE,DR,DA,DIU,DIV,DIW
  1.  ;S DA=BCHR,DDSFILE=90002,DR="[BCH ENTER PATIENT DATA]" D ^DDS
  1.  ;K DR,DA,DDSFILE,DIC,DIE
  1.  ;I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!!  ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q
  1.  ;Q:$G(^BCHR(BCHR,11))]""
  1.  I Y=-1 W !!,"A patient is Required" G GETPAT
  1.  S BCHNRPAT=+Y
  1.  I $P(Y,U,3) D  I 1
  1.  .W !!,"Please review and update if necessary this non-registered patient's data:"
  1.  .S DIE="^BCHRPAT(",DR="[BCH EDIT NON REG PT]",DA=BCHNRPAT D ^DIE K DA,DIE,DR
  1.  E  D
  1.  .W !!,"You now have the opportunity to update this patient's demographic data,"
  1.  .W !,"(DOB, Gender, Community of Residene, Tribe)",!
  1.  .S DIR(0)="Y",DIR("A")="Do you want to update this patient's demographic information?",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  .I 'Y Q
  1.  .I $D(DIRUT) Q
  1.  .S DIE="^BCHRPAT(",DR="[BCH EDIT NON REG PT]",DA=BCHNRPAT D ^DIE K DA,DIE,DR
  1.  D GENREC
  1.  Q
  1. GENREC ;create CHR record
  1.  S BCHEV("TYPE")="A"
  1.  D ^XBFMK
  1.  S APCDOVRR=1
  1.  S BCHOVRR=1
  1.  W !!,"Creating new record for ",$S(DFN:$P(^DPT(DFN,0),U),1:$P(^BCHRPAT(BCHNRPAT,0),U,1)),"."
  1.  ;I 'DFN W !!,"Creating CHR record."
  1.  K DD,D0,DO,DIC,DA,DR S DIC(0)="EL",DIC="^BCHR(",DLAYGO=90002,DIADD=1,X=$P(^BCHGROUP(BCHFID,0),U,4)
  1.  S BCHG0=^BCHGROUP(BCHFID,0)
  1.  S DIC("DR")=".02////"_$P(BCHG0,U,2)_";.03////"_$P(BCHG0,U,3)_";.04////"_$G(DFN)_";.05////"_$P(BCHG0,U,5)_";.06////"_$P(BCHG0,U,6)_";.12///1"
  1.  S DIC("DR")=DIC("DR")_";.16////"_DUZ_";.17////"_DT_";.22////"_DT_";.26////H;.29///1"
  1.  S DIC("DR")=DIC("DR")_";.11////"_$S(BCHHIT=1:$P(BCHG0,U,11),1:0) ;IHS/CMI/TMJ PATCH #16 Travel time to one patient
  1.  D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
  1.  I Y=-1 W !!,$C(7),$C(7),"ERROR generating CHR record!!  Deleting Record.",! D ^XBFMK Q
  1.  S BCHR=+Y
  1.  I BCHNRPAT S DA=BCHR,DIE=90002,DR="1112////"_BCHNRPAT D ^DIE K DIE,DA,DR
  1. POV ;create pov records
  1.  S BCHOVRR=1
  1.  S BCHX=0 F  S BCHX=$O(^BCHRGAS("AD",BCHFID,BCHX)) Q:BCHX'=+BCHX  D
  1.  .S BCHG0=^BCHRGAS(BCHX,0)
  1.  .D ^XBFMK
  1.  .S BCHPOVM=$P(BCHG0,U,5)/BCHNUM S BCHPOVM=(BCHPOVM+.5)\1
  1.  .K DD,D0,DO,DIC,DA,DR S DIC="^BCHRPROB(",DIC(0)="EL",DLAYGO=90002.01,DIADD=1,X=$P(BCHG0,U)
  1.  .S DIC("DR")=".02////"_$G(DFN)_";.03////"_BCHR_";.04////"_$P(BCHG0,U,4)_";.05///"_BCHPOVM_";.06////"_$P(BCHG0,U,6)
  1.  .D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,DO
  1.  .I Y<0 W !!,"Creating pov record failed.!!  Notify PROGRAMMER!",!!
  1.  D ^XBFMK
  1.  ;M ^BCHR(BCHR,51)=^BCHGROUP(BCHFID,51)
  1.  ;M ^BCHR(BCHR,61)=^BCHGROUP(BCHFID,61)
  1.  ;M ^BCHR(BCHR,71)=^BCHGROUP(BCHFID,71)
  1. SOAP ;
  1.  ;W ! S DIE="^BCHR(",DR="5101;6101;7101",DA=BCHR D ^DIE D ^XBFMK
  1.  D GETMEAS
  1. EDITR ;
  1.  S DIR(0)="Y",DIR("A")="Do you wish to edit anything in this record",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I Y D EDIT
  1.  ;DO PCC LINK
  1.  D PROTOCOL^BCHUADD1
  1.  S BCHHIT=BCHHIT+1
  1.  ;update 2101 multiple
  1.  D ^XBFMK K DIADD,DLAYGO
  1.  S DIC="^BCHGROUP("_BCHFID_",21,",DIC(0)="L",DIC("P")=$P(^DD(90002.97,2101,0),U,2),DA(1)=BCHFID,X="`"_BCHR D ^DIC
  1.  I Y=-1 W !!,"adding visit to group file entry failed.  Notify supervisor." H 2
  1.  D ^XBFMK K DIADD,DLAYGO
  1.  Q
  1. GETMEAS ;
  1.  I '$G(DFN),'$G(^BCHR(BCHR,11))="" Q  ;no patient so no measurements
  1.  W !
  1.  S DIR(0)="Y",DIR("A")=$S('$G(BCHUABFO):"Any MEASUREMENTS, TESTS or REPRODUCTIVE FACTORS",1:"Any MEASUREMENTS/TESTS"),DIR("B")="Y" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  Q:$D(DIRUT)
  1.  Q:'Y
  1.  S DA=BCHR,DDSFILE=90002,DR="[BCH ENTER MEASUREMENTS/TESTS" D ^DDS
  1.  I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!!  ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG D ^XBFMK Q
  1.  D ^XBFMK
  1.  Q
  1. EDIT ;
  1.  W !
  1.  S DA=BCHR,DDSFILE=90002,DR="[BCH EDIT RECORD DATA]" D ^DDS
  1.  K DR,DA,DDSFILE,DIC,DIE
  1.  I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!!  ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG Q
  1.  S BCHPAT=$P(^BCHR(BCHR,0),U,4)
  1.  Q:BCHPAT=""
  1.  ;backfill pt ptr in CHR POV
  1.  S BCHX=0 F  S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX  D
  1.  .S DIE="^BCHRPROB(",DA=BCHX,DR=".02////"_BCHPAT,DITC=""
  1.  .D ^DIE
  1.  .K DIE,DA,DR,DIU,DIV,DIW,DIY,DITC
  1.  .I $D(Y) W !,"error updating pov's with patient, NOTIFY PROGRAMMER" H 5
  1.  .Q
  1.  ;backfill pt ptr in CHR EDUC
  1.  S BCHX=0 F  S BCHX=$O(^BCHRPED("AD",BCHR,BCHX)) Q:BCHX'=+BCHX  D
  1.  .S DIE="^BCHRPED(",DA=BCHX,DR=".02////"_BCHPAT,DITC=""
  1.  .D ^DIE
  1.  .K DIE,DA,DR,DIU,DIV,DIW,DIY,DITC
  1.  .I $D(Y) W !,"error updating educ's with patient, NOTIFY PROGRAMMER" H 5
  1.  .Q
  1.  Q
  1. EXIT ;clean up and exit
  1.  K DIC,DR,DA,X,Y,DIU,DIU,D0,DO,DI
  1.  K BCHHIT,BCHX
  1.  K DIR,X,Y,DIC,DR,DA,D0,DO,DIZ,D
  1.  Q
  1. ERROR ;
  1.  W !!,$C(7),$C(7),"You have NOT completed entry of all of the ",BCHNUM," patients!!"
  1.  W !,"This means that you MUST enter each of the remaining visits individually,",!,"using ",($P(^BCHGROUP(BCHFID,0),U,11)\BCHNUM)," minutes activity time for each patient.",!!!
  1.  ;really want to quit?
  1.  K DIR S DIR(0)="Y",DIR("A")="Are you sure you wish to stop",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I $D(DIRUT) S BCHSTOP=1 Q
  1.  I Y S BCHSTOP=1 Q
  1.  S BCHSTOP=0
  1.  Q
  1. PAUSE ;
  1.  S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  Q
  1. DEL ;
  1.  S DIK="^BCHR(",DA=BCHR D ^DIK K DA,DIK
  1.  W !,"Record deleted."
  1.  D PAUSE
  1.  Q