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 ""
