BCHEGR1.m

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