BCHADRS.m

BCHADRS ; IHS/CMI/LAB - ROLL AND SCROLL POV ENTRY ; 

 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 ;

POVS(BCHR) ;

 D EN^XBNEW("POVS1^BCHADRS","BCHR")

 K Y

 Q

POVS1 ;

 NEW BCHC,BCHCM,BCHPAT

 S BCHPAT=$P(^BCHR(BCHR,0),U,4)

POV1 W !!?3,"Assessments/Purpose of Visits"

 I '$O(^BCHRPROB("AD",BCHR,0)) S BCHC=0 W ":  None currently recorded" G FM12

 D EN^DDIOL($$REPEAT^XLFSTR("~",75),"","!?3")

 W !?1,"#",?5,"PROBLEM",?27,"SERVICE",?48,"MINUTES"

 K BCHCM S X=0,BCHC=0 F  S X=$O(^BCHRPROB("AD",BCHR,X)) Q:X'=+X  D

 .S BCHC=BCHC+1,BCHCM(BCHC)=X

 .W !?1,BCHC,")  ",?5,$E($$VAL^XBDIQ1(90002.01,X,.01),1,20),?27,$E($$VAL^XBDIQ1(90002.01,X,.04),1,20),?50,$$VAL^XBDIQ1(90002.01,X,.05),!?5,"NARRATIVE: ",$$VAL^XBDIQ1(90002.01,X,.06)

FM12 ;

 D EN^DDIOL("","","!")

 K DIR

 S DIR(0)="S^A:Add a Problem/Activity"_$S(BCHC:";E:Edit an Existing Problem/Activity;D:Delete a Problem/Activity",1:"")_";Q:Quit, I'm Done with Assessment Entry"

 S DIR("A")="Which action",DIR("B")="" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G FM13

 I Y="Q" S BCHDONE=1 G FM13

 S Y="FM"_Y

 D @Y

 G POV1

FM13 ; 

 K Y

 Q

 ;

FME ;

 D EN^DDIOL("","","!")

 K DIR

 S DIR(0)="N^1:"_BCHC_":0",DIR("A")="Edit Which One" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) Q

 K DIC,DA,DR

 S DA=BCHCM(Y)

 S DA(1)=BCHTP,DIE="^BCHRPROB("_DA(1)_",17,",DR=".01;.02" D ^DIE K DIE,DA,DR

 Q

FMD ;

 D EN^DDIOL("","","!")

 K DIR

 S DIR(0)="N^1:"_BCHC_":0",DIR("A")="Delete Which One" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) Q

 S DA=BCHCM(Y)

 S DA(1)=BCHTP,DIE="^BCHRPROB("_DA(1)_",17,",DR=".01///@" D ^DIE K DIE,DA,DR

 K DIC,DA,DR

 Q

FMA ;

 ;ADDING NEW

 S DIE="^BCHR(",DA=BCHR,DR="[BCH POV ADD (535)]"

 D ^DIE

 K DIE,DA,DR

 Q

GETNARRS(PC,SC) ;

 K BCHCANNN,BCHCOUNT

 K ^BCHRPROB(DA,81)

 NEW PCSC,SCE,C,X

 S C=0

 S SC=$G(SC)

 I SC S SCE=$P(^BCHTSERV(SC,0),U,3)

 S PC=$G(PC)

 I PC S PC=$P(^BCHTPROB(PC,0),U,2)

 S PCSC=PC_"-"_SCE

 S X=0 F  S X=$O(^BCHTCNAR(X)) Q:X'=+X  D

 .I $D(^BCHTCNAR(X,11,"B",SC))!($D(^BCHTSERV(X,12,"B",PCSC))) D

 ..S C=C+1,BCHCANNN(C)=C_U_$$VAL^XBDIQ1(90002.59,X,.01)_U_X

 ..;D PUT^DDSVAL(90002.0181,.DA,.01,$P(BCHCANNN(C),U,1),"","E")

 ..;D PUT^DDSVAL(90002.0181,.DA,.02,$P(BCHCANNN(C),U,2),"","E")

 ..S ^BCHRPROB(DA,81,C,0)=C_U_$P(BCHCANNN(C),U,2)

 ..S ^BCHRPROB(DA,81,"B",C,C)=""

 S ^BCHRPROB(DA,81,0)="^90002.0181A^"_C_"^"_C

 S BCHCOUNT=C

 Q

GETNARR(BCHRDA) ;

 D EN^XBNEW("GETNARR1^BCHADRS","BCHRDA")

 K Y

 Q

CANNEDN(BCHRDA) ;EP - return canned narrative

 NEW BCHX

 ;*****CALLED FROM SCREENMAN

 S BCHX=$P(^BCHRPROB(BCHRDA,0),U,4) I BCHX,$P($G(^BCHTSERV(BCHX,0)),U,4) D EN^DDIOL("For services PC, HE, CF, CM, MP, EC and HS you must enter a narrative.") Q ""

 Q $E($P(^BCHTPROB($$VALI^XBDIQ1(90002.01,BCHRDA,.01),0),U),1,40)_":"_$E($P(^BCHTSERV($$VALI^XBDIQ1(90002.01,BCHRDA,.04),0),U),1,40)

GETNARR1 ;

 NEW BCHC,BCHCM,BCHPAT,BCHX,BCHNARR,APCDOVRR

 ;S BCHPAT=$P(^BCHR(BCHR,0),U,4)

CN ;

 W ! K DIR S DIR(0)="Y",DIR("A")="  Canned Narrative" KILL DA D ^DIR KILL DIR

 I X="^" W !,"Response is Required." G CN

 S APCDOVRR=1

 I Y G CN1

 S BCHX=$P(^BCHRPROB(BCHRDA,0),U,4) I BCHX,$P($G(^BCHTSERV(BCHX,0)),U,4) D EN^DDIOL("Please Note: For services PC, HE, CF, CM, MP, EC and HS you must enter a narrative.")

GN ;K DIR S DIR(0)="90002.01,.06O",DIR("A")="NARRATIVE" KILL DA D ^DIR KILL DIR

 ;K DIR S DIR(0)="FO^1:80",DIR("A")="NARRATIVE" KILL DA D ^DIR KILL DIR

 S DA=BCHRDA,DIE="^BCHRPROB(",DR="9101NARRATIVE" D ^DIE K DIE,DA,DR

 S BCHNARR=$P($G(^BCHRPROB(BCHRDA,91)),U,1) I BCHNARR="" S BCHNARR=$$CANNEDN(BCHRDA) G:BCHNARR="" GN D  Q

 .S DA=BCHRDA,DIE="^BCHRPROB(",DR=".06///"_BCHNARR D ^DIE K DIE,DA,DR

 S DA=BCHRDA,DIE="^BCHRPROB(",DR=".06////"_BCHNARR D ^DIE K DIE,DA,DR

 Q

CN1 ;

 ;write out narratives

 W !,"Please select the narrative you wish to use.",!

 NEW PCSC,SCE,C,X,PC,SC

 S C=0

 S SC=$P(^BCHRPROB(BCHRDA,0),U,4)

 I SC S SCE=$P(^BCHTSERV(SC,0),U,3)

 S PC=$P(^BCHRPROB(BCHRDA,0),U,1)

 I PC S PC=$P(^BCHTPROB(PC,0),U,2)

 S PCSC=PC_"-"_SCE

 S X=0 F  S X=$O(^BCHTCNAR(X)) Q:X'=+X  D

 .I $D(^BCHTCNAR(X,11,"B",SC))!($D(^BCHTSERV(X,12,"B",PCSC))) D

 ..S C=C+1,BCHCANNN(C)=C_U_$$VAL^XBDIQ1(90002.59,X,.01)_U_X

 S BCHCOUNT=C

 S X=0 F  S X=$O(BCHCANNN(X)) Q:X'=+X  W !?5,X,") ",$P(BCHCANNN(X),U,2)

 K DIR S DIR(0)="NO^1:"_BCHCOUNT_":0",DIR("A")="Which Narrative" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) D GN Q

 I Y="" D GN Q

 S BCHNARR=$P(BCHCANNN(Y),U,2) S DA=BCHRDA,DIE="^BCHRPROB(",DR=".06//"_BCHNARR D ^DIE K DIE,DA,DR

 Q

WTD ;

 D EN^XBNEW("WTD1^BCHADRS","BCHDEL")

 K Y

 Q

WTD1 ;

 K DIR

 S DIR(0)="S^G:GO Back and Enter an Assessment;D:Delete the Record and Quit Entry of this Record",DIR("A")="What would you like to do",DIR("B")="G" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) S BCHDEL=0 Q

 I Y="G" S BCHDEL=0 Q

 S BCHDEL=1

 Q

DEFNS(R) ;EP - called from screenman screen

 I '$G(R) Q ""

 NEW X,Y,G,Z

 S G=1

 S X=0 F  S X=$O(^BCHRPROB("AD",R,X)) Q:X'=+X  D

 .S Y=$P(^BCHRPROB(X,0),U,1)

 .I Y S Y=$P(^BCHTPROB(Y,0),U,2)

 .I Y="AM" S G=0 Q

 .I Y="LT" S G=0 Q

 .I Y["-" S G=0 Q

 .S Z=$P(^BCHRPROB(X,0),U,4)

 .I Z S Y=$P(^BCHTSERV(Z,0),U,3)

 .I Y="LT" S G=0 Q

 .I Y="AM" S G=0 Q

 .I Y="NF" S G=0 Q

 .I Y="OT" S G=0 Q

 .Q

 Q G

DEFAL(R) ;EP - called from screenman screen

 I '$G(R) Q ""

 NEW X,Y,G,Z

 S G=""

 S X=0 F  S X=$O(^BCHRPROB("AD",R,X)) Q:X'=+X  D

 .S Y=$P(^BCHRPROB(X,0),U,1)

 .I Y S Y=$P(^BCHTPROB(Y,0),U,2)

 .;I Y="AM" S G=0 Q

 .I Y="LT" S G="NONE" Q

 .;I Y["-" S G=0 Q

 .S Z=$P(^BCHRPROB(X,0),U,4)

 .I Z S Y=$P(^BCHTSERV(Z,0),U,3)

 .I Y="LT" S G="NONE" Q

 .;I Y="AM" S G=0 Q

 .;I Y="NF" S G=0 Q

 .I Y="OT" S G="NONE" Q

 .Q

 I G]"" Q $O(^BCHTACTL("B",G,0))

 Q ""

BCHADRS   ; IHS/CMI/LAB - ROLL AND SCROLL POV ENTRY ; 

 +1       ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 +2       ;

POVS(BCHR) ;

 +1        DO EN^XBNEW("POVS1^BCHADRS","BCHR")

 +2        KILL Y

 +3        QUIT 

POVS1     ;

 +1        NEW BCHC,BCHCM,BCHPAT

 +2        SET BCHPAT=$PIECE(^BCHR(BCHR,0),U,4)

POV1       WRITE !!?3,"Assessments/Purpose of Visits"

 +1        IF '$ORDER(^BCHRPROB("AD",BCHR,0))

               SET BCHC=0

               WRITE ":  None currently recorded"

               GOTO FM12

 +2        DO EN^DDIOL($$REPEAT^XLFSTR("~",75),"","!?3")

 +3        WRITE !?1,"#",?5,"PROBLEM",?27,"SERVICE",?48,"MINUTES"

 +4        KILL BCHCM

           SET X=0

           SET BCHC=0

           FOR 

               SET X=$ORDER(^BCHRPROB("AD",BCHR,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +5                SET BCHC=BCHC+1

                   SET BCHCM(BCHC)=X

 +6                WRITE !?1,BCHC,")  ",?5,$EXTRACT($$VAL^XBDIQ1(90002.01,X,.01),1,20),?27,$EXTRACT($$VAL^XBDIQ1(90002.01,X,.04),1,20),?50,$$VAL^XBDIQ1(90002.01,X,.05),!?5,"NARRATIVE: ",$$VAL^XBDIQ1(90002.01,X,.06)

               End DoDot:1

FM12      ;

 +1        DO EN^DDIOL("","","!")

 +2        KILL DIR

 +3        SET DIR(0)="S^A:Add a Problem/Activity"_$SELECT(BCHC:";E:Edit an Existing Problem/Activity;D:Delete a Problem/Activity",1:"")_";Q:Quit, I'm Done with Assessment Entry"

 +4        SET DIR("A")="Which action"

           SET DIR("B")=""

           KILL DA

           DO ^DIR

           KILL DIR

 +5        IF $DATA(DIRUT)

               GOTO FM13

 +6        IF Y="Q"

               SET BCHDONE=1

               GOTO FM13

 +7        SET Y="FM"_Y

 +8        DO @Y

 +9        GOTO POV1

FM13      ; 

 +1        KILL Y

 +2        QUIT 

 +3       ;

FME       ;

 +1        DO EN^DDIOL("","","!")

 +2        KILL DIR

 +3        SET DIR(0)="N^1:"_BCHC_":0"

           SET DIR("A")="Edit Which One"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               QUIT 

 +5        KILL DIC,DA,DR

 +6        SET DA=BCHCM(Y)

 +7        SET DA(1)=BCHTP

           SET DIE="^BCHRPROB("_DA(1)_",17,"

           SET DR=".01;.02"

           DO ^DIE

           KILL DIE,DA,DR

 +8        QUIT 

FMD       ;

 +1        DO EN^DDIOL("","","!")

 +2        KILL DIR

 +3        SET DIR(0)="N^1:"_BCHC_":0"

           SET DIR("A")="Delete Which One"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               QUIT 

 +5        SET DA=BCHCM(Y)

 +6        SET DA(1)=BCHTP

           SET DIE="^BCHRPROB("_DA(1)_",17,"

           SET DR=".01///@"

           DO ^DIE

           KILL DIE,DA,DR

 +7        KILL DIC,DA,DR

 +8        QUIT 

FMA       ;

 +1       ;ADDING NEW

 +2        SET DIE="^BCHR("

           SET DA=BCHR

           SET DR="[BCH POV ADD (535)]"

 +3        DO ^DIE

 +4        KILL DIE,DA,DR

 +5        QUIT 

GETNARRS(PC,SC) ;

 +1        KILL BCHCANNN,BCHCOUNT

 +2        KILL ^BCHRPROB(DA,81)

 +3        NEW PCSC,SCE,C,X

 +4        SET C=0

 +5        SET SC=$GET(SC)

 +6        IF SC

               SET SCE=$PIECE(^BCHTSERV(SC,0),U,3)

 +7        SET PC=$GET(PC)

 +8        IF PC

               SET PC=$PIECE(^BCHTPROB(PC,0),U,2)

 +9        SET PCSC=PC_"-"_SCE

 +10       SET X=0

           FOR 

               SET X=$ORDER(^BCHTCNAR(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +11               IF $DATA(^BCHTCNAR(X,11,"B",SC))!($DATA(^BCHTSERV(X,12,"B",PCSC)))

                       Begin DoDot:2

 +12                       SET C=C+1

                           SET BCHCANNN(C)=C_U_$$VAL^XBDIQ1(90002.59,X,.01)_U_X

 +13      ;D PUT^DDSVAL(90002.0181,.DA,.01,$P(BCHCANNN(C),U,1),"","E")

 +14      ;D PUT^DDSVAL(90002.0181,.DA,.02,$P(BCHCANNN(C),U,2),"","E")

 +15                       SET ^BCHRPROB(DA,81,C,0)=C_U_$PIECE(BCHCANNN(C),U,2)

 +16                       SET ^BCHRPROB(DA,81,"B",C,C)=""

                       End DoDot:2

               End DoDot:1

 +17       SET ^BCHRPROB(DA,81,0)="^90002.0181A^"_C_"^"_C

 +18       SET BCHCOUNT=C

 +19       QUIT 

GETNARR(BCHRDA) ;

 +1        DO EN^XBNEW("GETNARR1^BCHADRS","BCHRDA")

 +2        KILL Y

 +3        QUIT 

CANNEDN(BCHRDA) ;EP - return canned narrative

 +1        NEW BCHX

 +2       ;*****CALLED FROM SCREENMAN

 +3        SET BCHX=$PIECE(^BCHRPROB(BCHRDA,0),U,4)

           IF BCHX

               IF $PIECE($GET(^BCHTSERV(BCHX,0)),U,4)

                   DO EN^DDIOL("For services PC, HE, CF, CM, MP, EC and HS you must enter a narrative.")

                   QUIT ""

 +4        QUIT $EXTRACT($PIECE(^BCHTPROB($$VALI^XBDIQ1(90002.01,BCHRDA,.01),0),U),1,40)_":"_$EXTRACT($PIECE(^BCHTSERV($$VALI^XBDIQ1(90002.01,BCHRDA,.04),0),U),1,40)

GETNARR1  ;

 +1        NEW BCHC,BCHCM,BCHPAT,BCHX,BCHNARR,APCDOVRR

 +2       ;S BCHPAT=$P(^BCHR(BCHR,0),U,4)

CN        ;

 +1        WRITE !

           KILL DIR

           SET DIR(0)="Y"

           SET DIR("A")="  Canned Narrative"

           KILL DA

           DO ^DIR

           KILL DIR

 +2        IF X="^"

               WRITE !,"Response is Required."

               GOTO CN

 +3        SET APCDOVRR=1

 +4        IF Y

               GOTO CN1

 +5        SET BCHX=$PIECE(^BCHRPROB(BCHRDA,0),U,4)

           IF BCHX

               IF $PIECE($GET(^BCHTSERV(BCHX,0)),U,4)

                   DO EN^DDIOL("Please Note: For services PC, HE, CF, CM, MP, EC and HS you must enter a narrative.")

GN        ;K DIR S DIR(0)="90002.01,.06O",DIR("A")="NARRATIVE" KILL DA D ^DIR KILL DIR

 +1       ;K DIR S DIR(0)="FO^1:80",DIR("A")="NARRATIVE" KILL DA D ^DIR KILL DIR

 +2        SET DA=BCHRDA

           SET DIE="^BCHRPROB("

           SET DR="9101NARRATIVE"

           DO ^DIE

           KILL DIE,DA,DR

 +3        SET BCHNARR=$PIECE($GET(^BCHRPROB(BCHRDA,91)),U,1)

           IF BCHNARR=""

               SET BCHNARR=$$CANNEDN(BCHRDA)

               IF BCHNARR=""

                   GOTO GN

               Begin DoDot:1

 +4                SET DA=BCHRDA

                   SET DIE="^BCHRPROB("

                   SET DR=".06///"_BCHNARR

                   DO ^DIE

                   KILL DIE,DA,DR

               End DoDot:1

               QUIT 

 +5        SET DA=BCHRDA

           SET DIE="^BCHRPROB("

           SET DR=".06////"_BCHNARR

           DO ^DIE

           KILL DIE,DA,DR

 +6        QUIT 

CN1       ;

 +1       ;write out narratives

 +2        WRITE !,"Please select the narrative you wish to use.",!

 +3        NEW PCSC,SCE,C,X,PC,SC

 +4        SET C=0

 +5        SET SC=$PIECE(^BCHRPROB(BCHRDA,0),U,4)

 +6        IF SC

               SET SCE=$PIECE(^BCHTSERV(SC,0),U,3)

 +7        SET PC=$PIECE(^BCHRPROB(BCHRDA,0),U,1)

 +8        IF PC

               SET PC=$PIECE(^BCHTPROB(PC,0),U,2)

 +9        SET PCSC=PC_"-"_SCE

 +10       SET X=0

           FOR 

               SET X=$ORDER(^BCHTCNAR(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +11               IF $DATA(^BCHTCNAR(X,11,"B",SC))!($DATA(^BCHTSERV(X,12,"B",PCSC)))

                       Begin DoDot:2

 +12                       SET C=C+1

                           SET BCHCANNN(C)=C_U_$$VAL^XBDIQ1(90002.59,X,.01)_U_X

                       End DoDot:2

               End DoDot:1

 +13       SET BCHCOUNT=C

 +14       SET X=0

           FOR 

               SET X=$ORDER(BCHCANNN(X))

               IF X'=+X

                   QUIT 

               WRITE !?5,X,") ",$PIECE(BCHCANNN(X),U,2)

 +15       KILL DIR

           SET DIR(0)="NO^1:"_BCHCOUNT_":0"

           SET DIR("A")="Which Narrative"

           KILL DA

           DO ^DIR

           KILL DIR

 +16       IF $DATA(DIRUT)

               DO GN

               QUIT 

 +17       IF Y=""

               DO GN

               QUIT 

 +18       SET BCHNARR=$PIECE(BCHCANNN(Y),U,2)

           SET DA=BCHRDA

           SET DIE="^BCHRPROB("

           SET DR=".06//"_BCHNARR

           DO ^DIE

           KILL DIE,DA,DR

 +19       QUIT 

WTD       ;

 +1        DO EN^XBNEW("WTD1^BCHADRS","BCHDEL")

 +2        KILL Y

 +3        QUIT 

WTD1      ;

 +1        KILL DIR

 +2        SET DIR(0)="S^G:GO Back and Enter an Assessment;D:Delete the Record and Quit Entry of this Record"

           SET DIR("A")="What would you like to do"

           SET DIR("B")="G"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               SET BCHDEL=0

               QUIT 

 +4        IF Y="G"

               SET BCHDEL=0

               QUIT 

 +5        SET BCHDEL=1

 +6        QUIT 

DEFNS(R)  ;EP - called from screenman screen

 +1        IF '$GET(R)

               QUIT ""

 +2        NEW X,Y,G,Z

 +3        SET G=1

 +4        SET X=0

           FOR 

               SET X=$ORDER(^BCHRPROB("AD",R,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +5                SET Y=$PIECE(^BCHRPROB(X,0),U,1)

 +6                IF Y

                       SET Y=$PIECE(^BCHTPROB(Y,0),U,2)

 +7                IF Y="AM"

                       SET G=0

                       QUIT 

 +8                IF Y="LT"

                       SET G=0

                       QUIT 

 +9                IF Y["-"

                       SET G=0

                       QUIT 

 +10               SET Z=$PIECE(^BCHRPROB(X,0),U,4)

 +11               IF Z

                       SET Y=$PIECE(^BCHTSERV(Z,0),U,3)

 +12               IF Y="LT"

                       SET G=0

                       QUIT 

 +13               IF Y="AM"

                       SET G=0

                       QUIT 

 +14               IF Y="NF"

                       SET G=0

                       QUIT 

 +15               IF Y="OT"

                       SET G=0

                       QUIT 

 +16               QUIT 

               End DoDot:1

 +17       QUIT G

DEFAL(R)  ;EP - called from screenman screen

 +1        IF '$GET(R)

               QUIT ""

 +2        NEW X,Y,G,Z

 +3        SET G=""

 +4        SET X=0

           FOR 

               SET X=$ORDER(^BCHRPROB("AD",R,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +5                SET Y=$PIECE(^BCHRPROB(X,0),U,1)

 +6                IF Y

                       SET Y=$PIECE(^BCHTPROB(Y,0),U,2)

 +7       ;I Y="AM" S G=0 Q

 +8                IF Y="LT"

                       SET G="NONE"

                       QUIT 

 +9       ;I Y["-" S G=0 Q

 +10               SET Z=$PIECE(^BCHRPROB(X,0),U,4)

 +11               IF Z

                       SET Y=$PIECE(^BCHTSERV(Z,0),U,3)

 +12               IF Y="LT"

                       SET G="NONE"

                       QUIT 

 +13      ;I Y="AM" S G=0 Q

 +14      ;I Y="NF" S G=0 Q

 +15               IF Y="OT"

                       SET G="NONE"

                       QUIT 

 +16               QUIT 

               End DoDot:1

 +17       IF G]""

               QUIT $ORDER(^BCHTACTL("B",G,0))

 +18       QUIT ""