BCHEGR1 ; IHS/CMI/LAB - GROUP ENTRY ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;
;
GATHER ;EP
K ^TMP($J,"BCHEGR")
S BCHLINE=0,BCHD=$$FMADD^XLFDT(BCHRED,1)
F S BCHD=$O(^BCHGRPD("B",BCHD),-1) Q:BCHD'=+BCHD!($P(BCHD,".")<BCHRBD) D
.S BCHX=0 F S BCHX=$O(^BCHGRPD("B",BCHD,BCHX)) Q:BCHX'=+BCHX D
..S BCHN=$G(^BCHGRPD(BCHX,0))
..Q:$P(BCHN,U,7)'=BCHPROV
..S BCHLINE=BCHLINE+1,X=BCHLINE_")",$E(X,7)=$E(BCHD,4,5)_"/"_$E(BCHD,6,7)_"/"_$E(BCHD,2,3),$E(X,16)=$E($P(BCHN,U,3),1,20)
..S A=$P(BCHN,U,7) I A S A=$E($P(^VA(200,A,0),U,1),1,15),$E(X,37)=A
..S $E(X,54)=$P(BCHN,U,9)
..S $E(X,63)=$$POV(BCHX)
..S ^TMP($J,"BCHEGR",BCHLINE,0)=X,^TMP($J,"BCHEGR","IDX",BCHLINE,BCHLINE)=BCHX
Q
POV(R) ;
I 'R Q ""
NEW Y,X,P
S X=0,Y="" F S X=$O(^BCHGRPD(R,21,X)) Q:X'=+X!(Y]"") S P=$P(^BCHGRPD(R,21,X,0),U),S=$P(^BCHGRPD(R,21,X,0),U,3) Q:'P Q:'S S:Y]"" Y=Y_"; " S Y=Y_$P(^BCHTPROB(P,0),U,2)_" - "_$P(^BCHTSERV(S,0),U,3)
Q Y
PAUSE ;EP
K DIR
S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
PRTEF ;EP
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." D EXIT^BCHEGR Q
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT^BCHEGR Q
S BCHNG=0 S BCHNG=^TMP($J,"BCHEGR","IDX",R,R)
I '$D(^BCHGRPD(BCHNG,0)) W !,"Not a valid GROUP." K R,BCHNG,R1 D PAUSE,EXIT^BCHEGR Q
D FULL^VALM1
I '$O(^BCHGRPD(BCHNG,61,0)) W !!,"There were no visits created for this group." D PAUSE,EXIT^BCHEGR Q
W !!,"Forms will be generated for the following patient visits:"
S BCHY=0 F S BCHY=$O(^BCHGRPD(BCHNG,61,BCHY)) Q:'BCHY S BCHR=$P(^BCHGRPD(BCHNG,61,BCHY,0),U) I $D(^BCHR(BCHR,0)) D
.W !?2,$$VAL^XBDIQ1(90002,BCHR,1101),?34,$$VAL^XBDIQ1(90002,BCHR,.01)
W !! S DIR(0)="Y",DIR("A")="Do you wish to PRINT a hard copy encounter form for each patient in the group",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) D EXIT^BCHEGR Q
I 'Y D EXIT^BCHEGR Q
S XBRP="PRINT1^BCHEGR1",XBRC="",XBRX="EOJ^BCHEGR",XBNS="BCH"
D ^XBDBQUE
D EXIT^BCHEGR
;loop through all patients, records and print forms
W !!!!
Q
PRINT1 ;
S BCHGRPX=0 F S BCHGRPX=$O(^BCHGRPD(BCHNG,61,BCHGRPX)) Q:BCHGRPX'=+BCHGRPX!($G(BCHQUIT)) S BCHR=$P(^BCHGRPD(BCHNG,61,BCHGRPX,0),U,1) D PRINT1^BCHUFPP
Q
DISP ;EP - called from protocol
D EN^VALM2(XQORNOD(0),"OS")
NEW BCHG,BCHX
I '$D(VALMY) W !,"No records selected." D EXIT^BCHEGR Q
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT^BCHEGR Q
S BCHG=0 S BCHG=^TMP($J,"BCHEGR","IDX",R,R)
I '$D(^BCHGRPD(BCHG,0)) W !,"Not a valid GROUP." K BCHRDEL,R,BCHG,R1 D PAUSE,EXIT^BCHEGR Q
D FULL^VALM1
S %="Group Definition Display"
D VIEWR^XBLM("DISP1^BCHEGR1",%)
D EXIT^BCHEGR
Q
DUP ;EP
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) W !,"No records selected." D EXIT^BCHEGR Q
S R=$O(VALMY(0)) I 'R K R,VALMY,XQORNOD W !,"No record selected." D EXIT^BCHEGR Q
S BCHG=0 S BCHG=^TMP($J,"BCHEGR","IDX",R,R)
I '$D(^BCHGRPD(BCHG,0)) W !,"Not a valid GROUP." K BCHRDEL,R,BCHG,R1 D PAUSE D EXIT^BCHEGR Q
D FULL^VALM1
W !
K DIR S DIR(0)="D^:DT:EP",DIR("A")="Enter Date for the new group entry" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EXIT^BCHEGR Q
S BCHD=Y,BCHDATE=Y
S X=BCHD,DIC="^BCHGRPD(",DLAYGO=90002.67,DIADD=1,DIC(0)="L" K DD,DO D FILE^DICN
I Y=-1 W !!,"entry of new group failed." K DIADD,DLAYGO D ^XBFMK D EXIT^BCHEGR Q
S BCHNG=+Y
K DIADD,DLAYGO D ^XBFMK
K ^BCHGRPD("B",BCHD,BCHNG)
M ^BCHGRPD(BCHNG)=^BCHGRPD(BCHG)
K ^BCHGRPD(BCHNG,61) ;get rid of records
;per BJ 5/13/09 - get rid of deceased patients
NEW BCHX,P,BCHY
S BCHX=0 F S BCHX=$O(^BCHGRPD(BCHNG,51,BCHX)) Q:BCHX'=+BCHX D
.S P=$P($G(^BCHGRPD(BCHNG,51,BCHX,0)),U)
.Q:P=""
.Q:P["BCHPAT"
.S P=+P
.I $$DOD^AUPNPAT(P)]"" D
..S DA(1)=BCHNG,DA=BCHX,DIK="^BCHGRPD("_DA(1)_",51," D ^DIK K DA,DIK
S DA=BCHNG,DIE="^BCHGRPD(",DR=".01///"_BCHD_";.04////"_DT_";.12////"_DUZ_";.13////"_DT_";.15////"_DUZ D ^DIE
S DA=BCHNG,DIK="^BCHGRPD(" D IX1^DIK
;move over assessments
S BCHX=0 F S BCHX=$O(^BCHGRPDA("AD",BCHG,BCHX)) Q:BCHX'=+BCHX D
.;add new record
.S DIC="^BCHGRPDA(",X=$P(^BCHGRPDA(BCHX,0),U,1),DIC(0)="L",DIADD=1,DLAYGO=90002.68 D FILE^DICN
.I Y=-1 K DIC,DIADD,DLAYGO W !!,"Failed..." H 5 Q
.K DIC,DIADD,DLAYGO
.S BCHY=+Y
.M ^BCHGRPDA(BCHY)=^BCHGRPDA(BCHX)
.S DA=BCHY,DIK="^BCHGRPDA(" D IX1^DIK
.K DA,DIK
.S DIE="^BCHGRPDA(",DR=".03////"_BCHNG,DA=BCHY D ^DIE K DIE,DA,DR
D EDITGRP^BCHEGR
Q
DISP1 ;EP - called from XBLM
S DIC="^BCHGRPD(",DA=BCHG D EN^DIQ
NEW BCHX,F,V
W "Assessments:"
S BCHX=0 F S BCHX=$O(^BCHGRPDA("AD",BCHG,BCHX)) Q:BCHX'=+BCHX D
.F F=".01",".04",".05",".06" W ?14,$P(^DD(90002.68,F,0),U,1),":",?35,$$VAL^XBDIQ1(90002.68,BCHX,F),!
Q
DISP2 ;EP - called from XBLM
S DIC="^BCHGRPD(",DA=BCHNG D EN^DIQ
NEW BCHX,F,V
W "Assessments:"
S BCHX=0 F S BCHX=$O(^BCHGRPDA("AD",BCHNG,BCHX)) Q:BCHX'=+BCHX D
.F F=".01",".04",".05",".06" W ?14,$P(^DD(90002.68,F,0),U,1),":",?35,$$VAL^XBDIQ1(90002.68,BCHX,F),!
Q
BCHEGR1 ; IHS/CMI/LAB - GROUP ENTRY ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;
+3 ;
GATHER ;EP
+1 KILL ^TMP($JOB,"BCHEGR")
+2 SET BCHLINE=0
SET BCHD=$$FMADD^XLFDT(BCHRED,1)
+3 FOR
SET BCHD=$ORDER(^BCHGRPD("B",BCHD),-1)
IF BCHD'=+BCHD!($PIECE(BCHD,".")<BCHRBD)
QUIT
Begin DoDot:1
+4 SET BCHX=0
FOR
SET BCHX=$ORDER(^BCHGRPD("B",BCHD,BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:2
+5 SET BCHN=$GET(^BCHGRPD(BCHX,0))
+6 IF $PIECE(BCHN,U,7)'=BCHPROV
QUIT
+7 SET BCHLINE=BCHLINE+1
SET X=BCHLINE_")"
SET $EXTRACT(X,7)=$EXTRACT(BCHD,4,5)_"/"_$EXTRACT(BCHD,6,7)_"/"_$EXTRACT(BCHD,2,3)
SET $EXTRACT(X,16)=$EXTRACT($PIECE(BCHN,U,3),1,20)
+8 SET A=$PIECE(BCHN,U,7)
IF A
SET A=$EXTRACT($PIECE(^VA(200,A,0),U,1),1,15)
SET $EXTRACT(X,37)=A
+9 SET $EXTRACT(X,54)=$PIECE(BCHN,U,9)
+10 SET $EXTRACT(X,63)=$$POV(BCHX)
+11 SET ^TMP($JOB,"BCHEGR",BCHLINE,0)=X
SET ^TMP($JOB,"BCHEGR","IDX",BCHLINE,BCHLINE)=BCHX
End DoDot:2
End DoDot:1
+12 QUIT
POV(R) ;
+1 IF 'R
QUIT ""
+2 NEW Y,X,P
+3 SET X=0
SET Y=""
FOR
SET X=$ORDER(^BCHGRPD(R,21,X))
IF X'=+X!(Y]"")
QUIT
SET P=$PIECE(^BCHGRPD(R,21,X,0),U)
SET S=$PIECE(^BCHGRPD(R,21,X,0),U,3)
IF 'P
QUIT
IF 'S
QUIT
IF Y]""
SET Y=Y_"; "
SET Y=Y_$PIECE(^BCHTPROB(P,0),U,2)_" - "_$PIECE(^BCHTSERV(S,0),U,3)
+4 QUIT Y
PAUSE ;EP
+1 KILL DIR
+2 SET DIR(0)="EO"
SET DIR("A")="Press enter to continue...."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 QUIT
PRTEF ;EP
+1 DO EN^VALM2(XQORNOD(0),"OS")
+2 IF '$DATA(VALMY)
WRITE !,"No records selected."
DO EXIT^BCHEGR
QUIT
+3 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
DO EXIT^BCHEGR
QUIT
+4 SET BCHNG=0
SET BCHNG=^TMP($JOB,"BCHEGR","IDX",R,R)
+5 IF '$DATA(^BCHGRPD(BCHNG,0))
WRITE !,"Not a valid GROUP."
KILL R,BCHNG,R1
DO PAUSE
DO EXIT^BCHEGR
QUIT
+6 DO FULL^VALM1
+7 IF '$ORDER(^BCHGRPD(BCHNG,61,0))
WRITE !!,"There were no visits created for this group."
DO PAUSE
DO EXIT^BCHEGR
QUIT
+8 WRITE !!,"Forms will be generated for the following patient visits:"
+9 SET BCHY=0
FOR
SET BCHY=$ORDER(^BCHGRPD(BCHNG,61,BCHY))
IF 'BCHY
QUIT
SET BCHR=$PIECE(^BCHGRPD(BCHNG,61,BCHY,0),U)
IF $DATA(^BCHR(BCHR,0))
Begin DoDot:1
+10 WRITE !?2,$$VAL^XBDIQ1(90002,BCHR,1101),?34,$$VAL^XBDIQ1(90002,BCHR,.01)
End DoDot:1
+11 WRITE !!
SET DIR(0)="Y"
SET DIR("A")="Do you wish to PRINT a hard copy encounter form for each patient in the group"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+12 IF $DATA(DIRUT)
DO EXIT^BCHEGR
QUIT
+13 IF 'Y
DO EXIT^BCHEGR
QUIT
+14 SET XBRP="PRINT1^BCHEGR1"
SET XBRC=""
SET XBRX="EOJ^BCHEGR"
SET XBNS="BCH"
+15 DO ^XBDBQUE
+16 DO EXIT^BCHEGR
+17 ;loop through all patients, records and print forms
+18 WRITE !!!!
+19 QUIT
PRINT1 ;
+1 SET BCHGRPX=0
FOR
SET BCHGRPX=$ORDER(^BCHGRPD(BCHNG,61,BCHGRPX))
IF BCHGRPX'=+BCHGRPX!($GET(BCHQUIT))
QUIT
SET BCHR=$PIECE(^BCHGRPD(BCHNG,61,BCHGRPX,0),U,1)
DO PRINT1^BCHUFPP
+2 QUIT
DISP ;EP - called from protocol
+1 DO EN^VALM2(XQORNOD(0),"OS")
+2 NEW BCHG,BCHX
+3 IF '$DATA(VALMY)
WRITE !,"No records selected."
DO EXIT^BCHEGR
QUIT
+4 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
DO EXIT^BCHEGR
QUIT
+5 SET BCHG=0
SET BCHG=^TMP($JOB,"BCHEGR","IDX",R,R)
+6 IF '$DATA(^BCHGRPD(BCHG,0))
WRITE !,"Not a valid GROUP."
KILL BCHRDEL,R,BCHG,R1
DO PAUSE
DO EXIT^BCHEGR
QUIT
+7 DO FULL^VALM1
+8 SET %="Group Definition Display"
+9 DO VIEWR^XBLM("DISP1^BCHEGR1",%)
+10 DO EXIT^BCHEGR
+11 QUIT
DUP ;EP
+1 DO EN^VALM2(XQORNOD(0),"OS")
+2 IF '$DATA(VALMY)
WRITE !,"No records selected."
DO EXIT^BCHEGR
QUIT
+3 SET R=$ORDER(VALMY(0))
IF 'R
KILL R,VALMY,XQORNOD
WRITE !,"No record selected."
DO EXIT^BCHEGR
QUIT
+4 SET BCHG=0
SET BCHG=^TMP($JOB,"BCHEGR","IDX",R,R)
+5 IF '$DATA(^BCHGRPD(BCHG,0))
WRITE !,"Not a valid GROUP."
KILL BCHRDEL,R,BCHG,R1
DO PAUSE
DO EXIT^BCHEGR
QUIT
+6 DO FULL^VALM1
+7 WRITE !
+8 KILL DIR
SET DIR(0)="D^:DT:EP"
SET DIR("A")="Enter Date for the new group entry"
KILL DA
DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
DO EXIT^BCHEGR
QUIT
+10 SET BCHD=Y
SET BCHDATE=Y
+11 SET X=BCHD
SET DIC="^BCHGRPD("
SET DLAYGO=90002.67
SET DIADD=1
SET DIC(0)="L"
KILL DD,DO
DO FILE^DICN
+12 IF Y=-1
WRITE !!,"entry of new group failed."
KILL DIADD,DLAYGO
DO ^XBFMK
DO EXIT^BCHEGR
QUIT
+13 SET BCHNG=+Y
+14 KILL DIADD,DLAYGO
DO ^XBFMK
+15 KILL ^BCHGRPD("B",BCHD,BCHNG)
+16 MERGE ^BCHGRPD(BCHNG)=^BCHGRPD(BCHG)
+17 ;get rid of records
KILL ^BCHGRPD(BCHNG,61)
+18 ;per BJ 5/13/09 - get rid of deceased patients
+19 NEW BCHX,P,BCHY
+20 SET BCHX=0
FOR
SET BCHX=$ORDER(^BCHGRPD(BCHNG,51,BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+21 SET P=$PIECE($GET(^BCHGRPD(BCHNG,51,BCHX,0)),U)
+22 IF P=""
QUIT
+23 IF P["BCHPAT"
QUIT
+24 SET P=+P
+25 IF $$DOD^AUPNPAT(P)]""
Begin DoDot:2
+26 SET DA(1)=BCHNG
SET DA=BCHX
SET DIK="^BCHGRPD("_DA(1)_",51,"
DO ^DIK
KILL DA,DIK
End DoDot:2
End DoDot:1
+27 SET DA=BCHNG
SET DIE="^BCHGRPD("
SET DR=".01///"_BCHD_";.04////"_DT_";.12////"_DUZ_";.13////"_DT_";.15////"_DUZ
DO ^DIE
+28 SET DA=BCHNG
SET DIK="^BCHGRPD("
DO IX1^DIK
+29 ;move over assessments
+30 SET BCHX=0
FOR
SET BCHX=$ORDER(^BCHGRPDA("AD",BCHG,BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+31 ;add new record
+32 SET DIC="^BCHGRPDA("
SET X=$PIECE(^BCHGRPDA(BCHX,0),U,1)
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=90002.68
DO FILE^DICN
+33 IF Y=-1
KILL DIC,DIADD,DLAYGO
WRITE !!,"Failed..."
HANG 5
QUIT
+34 KILL DIC,DIADD,DLAYGO
+35 SET BCHY=+Y
+36 MERGE ^BCHGRPDA(BCHY)=^BCHGRPDA(BCHX)
+37 SET DA=BCHY
SET DIK="^BCHGRPDA("
DO IX1^DIK
+38 KILL DA,DIK
+39 SET DIE="^BCHGRPDA("
SET DR=".03////"_BCHNG
SET DA=BCHY
DO ^DIE
KILL DIE,DA,DR
End DoDot:1
+40 DO EDITGRP^BCHEGR
+41 QUIT
DISP1 ;EP - called from XBLM
+1 SET DIC="^BCHGRPD("
SET DA=BCHG
DO EN^DIQ
+2 NEW BCHX,F,V
+3 WRITE "Assessments:"
+4 SET BCHX=0
FOR
SET BCHX=$ORDER(^BCHGRPDA("AD",BCHG,BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+5 FOR F=".01",".04",".05",".06"
WRITE ?14,$PIECE(^DD(90002.68,F,0),U,1),":",?35,$$VAL^XBDIQ1(90002.68,BCHX,F),!
End DoDot:1
+6 QUIT
DISP2 ;EP - called from XBLM
+1 SET DIC="^BCHGRPD("
SET DA=BCHNG
DO EN^DIQ
+2 NEW BCHX,F,V
+3 WRITE "Assessments:"
+4 SET BCHX=0
FOR
SET BCHX=$ORDER(^BCHGRPDA("AD",BCHNG,BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+5 FOR F=".01",".04",".05",".06"
WRITE ?14,$PIECE(^DD(90002.68,F,0),U,1),":",?35,$$VAL^XBDIQ1(90002.68,BCHX,F),!
End DoDot:1
+6 QUIT
