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

BCHEGR.m

Go to the documentation of this file. 
  1. BCHEGR ; IHS/CMI/LAB - GROUP ENTRY 08 Nov 2011 3:34 PM ; 
  1.  ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
  1.  ;
  1.  ;
  1. START ;
  1.  W:$D(IOF) @IOF
  1.  D DONE
  1.  ;
  1. DATES ;
  1.  W !!,"You will be presented with a list of group definitions for the"
  1.  W !,"CHR you select for the date range you select.  You will then"
  1.  W !,"be able to select one of the group definitions which will be "
  1.  W !,"duplicated and used as a template for the group data you are "
  1.  W !,"about to enter.",!
  1.  S BCHPROV=""
  1.  D GETPROV^BCHUAR
  1.  I 'BCHPROV D DONE Q
  1.  K BCHRED,BCHRBD
  1.  W !,"Please enter the date range for displaying Group definitions."
  1.  K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date"
  1.  D ^DIR Q:Y<1  S BCHRBD=Y
  1.  K DIR S DIR(0)="DO^:DT:EXP",DIR("A")="Enter Ending Date"
  1.  D ^DIR Q:Y<1  S BCHRED=Y
  1.  ;
  1.  I BCHRED<BCHRBD D  G DATES
  1.  . W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
  1.  ;
  1.  ;
  1.  D EN,FULL^VALM1
  1.  D DONE
  1.  Q
  1. DONE ;
  1.  D EN^XBVK("BCH")
  1.  D ^XBFMK
  1.  D KILL^AUPNPAT
  1.  Q
  1. EN ;
  1.  K ^TMP($J,"BCHEGR")
  1.  D GATHER
  1.  D EN^VALM("BCH GROUP ENTRY")
  1.  D CLEAR^VALM1
  1.  Q
  1. GATHER ;
  1.  D GATHER^BCHEGR1
  1.  Q
  1. CTR(X,Y) ;EP - Center
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1. HDR ; -- header code
  1.  S VALMHDR(1)="Group Entry"
  1.  S X="",$E(X,7)="Date",$E(X,16)="Group Name",$E(X,37)="CHR",$E(X,54)="# SERVED",$E(X,63)="ASSESSMENTS"
  1.  S VALMHDR(2)=X
  1.  Q
  1.  ;
  1. INIT ;
  1.  D GATHER
  1.  S VALMCNT=BCHLINE
  1.  Q
  1.  ;lori edit
  1. HELP ;
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1. EDITDEF ;
  1.  D FULL^VALM1
  1.  W !!,"This action should be used to edit a group definition only.  If visits have"
  1.  W !,"already been entered for this group, you will not be able to edit the group"
  1.  W !,"definition.",!
  1.  D EN^VALM2(XQORNOD(0),"OS")
  1.  I '$D(VALMY) W !,"No records selected." D EXIT Q
  1.  S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT Q
  1.  S BCHNG=0 S BCHNG=^TMP($J,"BCHEGR","IDX",R,R)
  1.  I '$D(^BCHGRPD(BCHNG,0)) W !,"Not a valid GROUP." K BCHNG,R,BCHG,R1 D PAUSE D EXIT Q
  1.  D FULL^VALM1
  1.  I $O(^BCHGRPD(BCHNG,61,0)) W !!,"This group already has visits created.  You must use the REVIEW/EDIT",!,"GROUP VISITS to modify visits within this group." D PAUSE,EXIT Q
  1.  I $P(^BCHGRPD(BCHNG,0),U,18) W !!,"This Group's Notes have been signed.  You cannot edit the Group.",! D PAUSE,EXIT Q
  1.  S BCHDATE=$P($P(^BCHGRPD(BCHNG,0),U),".")
  1.  D EDITGRP
  1.  Q
  1. ADDGRP ;
  1.  D FULL^VALM1
  1.  ;add new group 
  1.  K DIR S DIR(0)="D^:"_DT_":EP",DIR("A")="Enter Date of the Group Activity" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) W !,"date not entered." D PAUSE,EXIT Q
  1.  S BCHDATE=Y
  1.  S X=BCHDATE,DIC="^BCHGRPD(",DLAYGO=90002.67,DIADD=1,DIC(0)="L",DIC("DR")=".07////"_BCHPROV_";.04////"_DT_";.12////"_DUZ K DD,DO D FILE^DICN
  1.  I Y=-1 W !!,"entry of new group failed." K DIADD,DLAYGO D ^XBFMK D EXIT Q
  1.  S BCHNG=+Y
  1.  K DIADD,DLAYGO D ^XBFMK
  1. EDITGRP ;EP
  1.  S APCDOVRR=1
  1.  S DA=BCHNG,DDSFILE=90002.67,DR="[BCH EDIT GROUP DEFINITION]" D ^DDS
  1.  I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!!  ***NOTIFY PROGRAMMER***" S BCHQUIT=1 K DIMSG D PAUSE,EXIT Q
  1.  ;must have a pov/provider
  1.  S E=0
  1.  I $P(^BCHGRPD(BCHNG,0),U,7)="" W !!,"Group must have CHR defined." S E=1
  1.  NEW X,G,C
  1.  I '$O(^BCHGRPDA("AD",BCHNG,0)) W !!,"Group must have at least one POV defined." S E=1
  1.  I E S BCHE="" D  G:BCHE="E" EDITGRP D:BCHE="Q" PAUSE,EXIT Q:BCHE="Q"  W !!,"deleting group definition." S DA=BCHNG,DIK="^BCHGRPD(" D ^DIK D PAUSE,EXIT Q
  1.  .S DIR(0)="S^E:Edit the Group definition;D:Delete this Group definition;Q:to exit and edit it later without deleting the group definition",DIR("A")="This group definition is not complete, do you wish to",DIR("B")="E" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) Q
  1.  .S BCHE=Y
  1.  .Q
  1.  ;now loop and get patients for the group
  1.  D ^XBFMK
  1.  W !!,"You have added the following group definition, please review it carefully",!,"before you proceed to add/update the patients in the group.",!
  1.  D DISP2^BCHEGR1
  1.  S DIR(0)="S^Y:Yes-group definition is accurate-continue to Patient List;N:No, I wish to edit the group definition;Q:I wish to QUIT and exit",DIR("A")="Do you wish to continue on to add patient visits for this group"
  1.  S DIR("B")="Y" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D PAUSE,EXIT Q
  1.  I Y="Q" D DELGRP,PAUSE,EXIT Q
  1.  I Y="N" G EDITGRP
  1. SENS ;check for sensitive patients
  1.  K BCHPAT
  1.  W !!!
  1.  W !,"You will be prompted to confirm the list of patients who were in the"
  1.  W !,$$VAL^XBDIQ1(90002.67,BCHNG,.03)," group on ",$$VAL^XBDIQ1(90002.67,BCHNG,.01),".",!
  1.  S BCHQ=""
  1.  D GETPATS
  1.  I BCHQ Q
  1.  D ADDREC
  1.  D EXIT
  1.  Q
  1. DUP ;EP -
  1.  D DUP^BCHEGR1
  1.  Q
  1. DISP ;EP - called from protocol
  1.  D DISP^BCHEGR1
  1.  Q
  1. PRTEF ;EP
  1.  D PRTEF^BCHEGR1
  1.  Q
  1. DELGRP ;EP - called from protocol
  1.  NEW BCHX
  1.  S BCHX=0 F  S BCHX=$O(^BCHGRPDA("AD",BCHNG,BCHX)) Q:BCHX'=+BCHX  S DA=BCHX,DIK="^BCHGRPDA(" D ^DIK
  1.  S DA=BCHNG,DIK="^BCHGRPD(" D ^DIK
  1.  Q
  1. ADDREC ;EP
  1.  D FULL^VALM1
  1.  K DIR
  1.  W !!,"Adding records for each individual patient in this group.",!
  1.  S BCHNUM=$P(^BCHGRPD(BCHNG,0),U,9)  ; # SERVED
  1.  K BCHDELQ S BCHNGX=0,BCHHIT=0 F  S BCHNGX=$O(^BCHGRPD(BCHNG,51,BCHNGX)) Q:BCHNGX'=+BCHNGX!($G(BCHDELQ))  D ADDREC1
  1.  K X1
  1. SIGN1 D PAUSE,EXIT
  1.  Q
  1. ADDREC1 ;EP
  1.  S BCHHIT=BCHHIT+1
  1.  S (DFN,BCHNRPAT)=""
  1.  S X=$P(^BCHGRPD(BCHNG,51,BCHNGX,0),U)
  1.  I X["AUPNPAT" S DFN=+X
  1.  I X["BCHRPAT" S BCHNRPAT=+X
  1. ADDREC2 ;
  1.  S BCHG0=^BCHGRPD(BCHNG,0)
  1.  S APCDOVRR=1,BCHOVRR=1
  1.  S BCHEV("TYPE")="A"
  1.  D ^XBFMK
  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(^BCHGRPD(BCHNG,0),U,1)
  1.  S DIC("DR")=".02////"_$P(BCHG0,U,2)_";.03////"_$P(BCHG0,U,7)_";.04////"_$G(DFN)_";1112///"_$G(BCHNRPAT)_";.05////"_$P(BCHG0,U,10)_";.06////"_$P(BCHG0,U,5)_";.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,8),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. POV ;create pov records
  1.  S BCHOVRR=1
  1.  S BCHX=0 F  S BCHX=$O(^BCHGRPDA("AD",BCHNG,BCHX)) Q:BCHX'=+BCHX  D
  1.  .S BCHG0=^BCHGRPDA(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.  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="^BCHGRPD("_BCHNG_",61,",DIC(0)="L",DIC("P")=$P(^DD(90002.67,6101,0),U,2),DA(1)=BCHNG,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")="N" 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 ;EP - clean up and exit
  1.  D TERM^VALM0
  1.  S VALMBCK="R"
  1.  D GATHER
  1.  S VALMCNT=BCHLINE
  1.  D HDR
  1. EOJ ;
  1.  K BCHV,BCHF,BCHDR,DFN,BCHR,BCHQUIT,BCHRDEL,BCHV,BCHVDLT,BCHNAME,BCHPTSV,BCHX,DFN,BCHERROR,BCHR0,BCHPNP,BCHGRPX
  1.  K BCHC,BCHD,BCHDONE,BCHEV,BCHG,BCHG0,BCHLINE,BCHN,BCHNG,BCHNGX,BCHMUM,BCHNRPAT,BCMP,BCHPATS,BCHPOVM,BCHPROB,BCHQ,BCHR,BCHX,BCHY
  1.  K DFN
  1.  D DIRX^BCHUADD
  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. 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
  1. GETPATS ;
  1.  K BCHPATS
  1.  S X=0 F  S X=$O(^BCHGRPD(BCHNG,51,X)) Q:X'=+X  S BCHPATS($P(^BCHGRPD(BCHNG,51,X,0),U,1))=""
  1. GETPATSA ;
  1.  I '$D(BCHPATS) G GETPATS1
  1.  W !!,"The following patients are currently assigned to this group:"
  1.  S BCHP=0,BCHC=0 F  S BCHP=$O(BCHPATS(BCHP)) Q:BCHP=""  D
  1.  .S BCHC=BCHC+1
  1.  .W !?2,BCHC,")  ",$$VAL^XBDIQ1($S(BCHP["AUPNPAT":2,1:90002.11),$P(BCHP,";",1),.01)
  1. GETPATS1 ;
  1.  D EN^DDIOL("","","!!")
  1.  K DIR
  1.  S DIR(0)="S^A:Add a Patient to the Group;D:Delete a Patient from the Group;F:Finished Entering Patients for this Group"
  1.  S DIR("A")="Which action",DIR("B")="" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G GETPATSE
  1.  I Y="F" S BCHDONE=1 G GETPATSE
  1.  S Y="FM"_Y
  1.  D @Y
  1.  G GETPATSA
  1. GETPATSE ;
  1.  S X=0,Y="",C=0
  1.  F  S X=$O(BCHPATS(X)) Q:X=""  D
  1.  .S C=C+1
  1.  W !,"You entered ",C," Patient Names.  Is this the total number of patients"
  1.  S DIR(0)="Y",DIR("A")="that were in the group",DIR("B")="Y" KILL DA D ^DIR KILL DIR
  1.  S BCHY=Y
  1.  I $D(DIRUT) S BCHQ="" D  D:BCHQ DELGRP G:BCHQ EXIT  G GETPATSE
  1.  .W !!,"You ""^""'ed out."
  1.  .S DIR(0)="S^D:DELETE the entire Group Definition and Quit;G:Go back to entering Patients",DIR("A")="What do you wish to do",DIR("B")="D" KILL DA D ^DIR KILL DIR
  1.  .I $D(DIRUT) S BCHQ=1 Q
  1.  .I Y="D" S BCHQ=1 Q
  1.  I 'Y G GETPATSA
  1.  D SET51
  1.  Q
  1. FMD ;
  1.  ;pick one here
  1.  W !!,"The following patients are currently assigned to this group:"
  1.  S BCHP=0,BCHC=0 F  S BCHP=$O(BCHPATS(BCHP)) Q:BCHP=""  D
  1.  .S BCHC=BCHC+1
  1.  .W !?2,BCHC,")  ",$$VAL^XBDIQ1($S(BCHP["AUPNPAT":2,1:90002.11),$P(BCHP,";",1),.01)
  1.  S DIR(0)="N^1:"_BCHC_":",DIR("A")="Which one do you want delete from the group" D ^DIR KILL DIR,DA
  1.  I $D(DIRUT) Q
  1.  I 'Y Q
  1.  S X="",C=0 F  S X=$O(BCHPATS(X)) Q:X=""  S C=C+1 I Y=C K BCHPATS(X)
  1.  Q
  1. FMA ;
  1.  D GETPAT^BCHEGR2
  1.  I BCHPT S BCHPATS(BCHPT_";"_$S(BCHPTT="R":"AUPNPAT(",1:"BCHRPAT("))="" Q
  1.  Q
  1. SET51 ;
  1.  K ^BCHGRPD(BCHNG,51)
  1.  S X="",C=0 F  S X=$O(BCHPATS(X)) Q:X=""  S C=C+1,^BCHGRPD(BCHNG,51,C,0)=X,^BCHGRPD(BCHNG,51,"B",X,C)=""
  1.  S ^BCHGRPD(BCHNG,51,0)="^90002.6751AV^"_C_"^"_C
  1.  S DA=BCHNG,DIE="^BCHGRPD(",DR=".09///"_C D ^DIE K DIE,DR,DA
  1.  Q