AMHBPL1 ; IHS/CMI/LAB - problem list update from list manager ;
;;4.0;IHS BEHAVIORAL HEALTH;**2,4**;JUN 18, 2010;Build 28
;
;
DIE ;
S DIE("NO^")=1
S DA=AMHPIEN,DIE="^AMHPPROB(",DR=AMHTEMP D ^DIE
KDIE ;kill all vars used by DIE
K DIE,DR,DA,DIU,DIV,DQ,D0,DO,DI,DIW,DIY,%,DQ,DLAYGO
Q
GETPROB ;EP - get record
S AMHPIEN=0
I 'AMHPRCNT W !!,"No problems to select" Q
S DIR(0)="N^1:"_AMHPRCNT_":0",DIR("A")="Select Problem" KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"No Problem Selected" Q
S AMHP=Y
S (X,Y)=0 F S X=$O(AMHBHPL("IDX",X)) Q:X'=+X!(AMHPIEN) I $O(AMHBHPL("IDX",X,0))=AMHP S Y=$O(AMHBHPL("IDX",X,0)),AMHPIEN=AMHBHPL("IDX",X,Y)
I '$D(^AMHPPROB(AMHPIEN,0)) W !,"Not a valid BEHAVIORAL HEALTH PROBLEM." K AMHP S AMHPIEN=0 Q
D FULL^VALM1 ;give me full control of screen
Q
ADD ;EP - called from protocol to add a problem to problem list
D FULL^VALM1 ; this gives me back all screen control
W:$D(IOF) @IOF W !!!,"Adding a new BH Problem for ",$P(^DPT(AMHBPLPT,0),U),".",!!
W "Purpose of Visit Diagnoses assigned to this patient in the past 90 days:",!
NEW AMHPOVS,X,Y,N,AMHC,AMHOTH,D,P,AMHANS,AMHNUM,AMHTY,AMHNNUM,AMHNIEN,AMHCODE,AMHPOVS1,AMHANS,AMHOTH,AMHAPIEN,AMHNARR
S AMHC=0
S X=0 F S X=$O(^AMHRPRO("AC",AMHPAT,X)) Q:X'=+X D
.Q:'$D(^AMHRPRO(X,0))
.S D=$P(^AMHRPRO(X,0),U,3)
.S D=$P($P($G(^AMHREC(D,0)),U,1),".")
.Q:D<$$FMADD^XLFDT(DT,-91)
.S Y=$$VAL^XBDIQ1(9002011.01,X,.01)
.S I=$P(^AMHRPRO(X,0),U,1)
.S N=$$VAL^XBDIQ1(9002012.2,$$VALI^XBDIQ1(9002011.01,X,.01),.02)
.S P=$$VAL^XBDIQ1(9002011.01,X,.04)
.S AMHPOVS(Y)=N_U_P_U_Y_U_I
S Y="" F S Y=$O(AMHPOVS(Y)) Q:Y="" D
.S AMHC=AMHC+1
.W $$LBLK(AMHC,3),") ",Y,?15,$P(AMHPOVS(Y),U,1),!
.S AMHPOVS1(AMHC)=AMHPOVS(Y)
S AMHC=AMHC+1,AMHOTH=AMHC
W $$LBLK(AMHC,3),") ","Any Other Diagnosis",!
S DIR(0)="NO^1:"_AMHC_":0",DIR("A")="Choose a Diagnosis",DIR("B")=AMHC KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"No diagnosis selected. " D PAUSE,EXIT Q
S AMHANS=Y
I AMHANS'=AMHOTH S AMHCODE=$P(AMHPOVS1(AMHANS),U,4) G ADD1
S AMHCODE=""
W !!
S DIR(0)="9002011.01,.01",DIR("A")="Enter Diagnosis to Add to the Problem List" KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"No diagnosis selected. " D PAUSE,EXIT Q
S AMHCODE=+Y
ADD1 ;
K DD,D0,DO,DINUM,DIC,DA,DR,DIADD
S AMHNUM=0,AMHTY="" F S AMHTY=$O(^AMHPPROB("AA",AMHPAT,AMHTY)) Q:AMHTY="" D
.S AMHNUM=$E(AMHTY,2,4) S AMHNUM=AMHNUM+1
I AMHNUM=0 S AMHNUM=1
S AMHNUM=+AMHNUM
S DIC(0)="EL",DIC="^AMHPPROB(",DLAYGO=9002011.51,DIADD=1,X=AMHCODE
S DIC("DR")=".02////"_AMHPAT_";.03////"_$$NOW^XLFDT_";.06////"_DUZ(2)_";.07////"_AMHNUM_";.08////"_$$NOW^XLFDT_";.15////"_DUZ
D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
I Y=-1 W !!,"error generating problem entry" D PAUSE,EXIT Q
S AMHAPIEN=+Y
S AMHNARR=$P(^AMHPROB(AMHCODE,0),U,2)
S APCDOVRR=1,AMHOVRR=1
S DIE("NO^")=1,DIE="^AMHPPROB(",DR=".05//"_AMHNARR,DA=AMHAPIEN D ^DIE D KDIE
STAT ;get status value
K DIR S DIR(0)="S^A:ACTIVE;I:INACTIVE",DIR("A")="STATUS",DIR("B")="ACTIVE" KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is a required response. " D DELADD G:'AMHDEL STAT S DA=AMHAPIEN,DIK="^AMHPPROB(" D ^DIK K DA,DIK D PAUSE,EXIT Q
I Y'="I",Y'="A" W !!,"This is a required response, must be A or I, ""^"" to exit and delete the problem." G STAT
S AMHANS=Y
S DIE="^AMHPPROB(",DR=".12////"_AMHANS_";.13",DA=AMHAPIEN D ^DIE D KDIE
NO ;
W !!
S DIR(0)="Y",DIR("A")="Add TREATMENT Note",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D PLUDE^AMHAPRB(AMHAPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I")),EXIT Q
I 'Y D PLUDE^AMHAPRB(AMHAPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I")),EXIT Q
S AMHNNUM=$$GETNUM^AMHLETN(AMHAPIEN)
W !
S DIC="^AMHPTP(",X=AMHNNUM,DIC("DR")=".02////"_AMHPAT_";.03////"_AMHAPIEN_";.05////"_DT,DIADD=1,DLAYGO=9002011.53,DIC(0)="EL"
D FILE^DICN
K DLAYGO,DIADD,DIC,DA
I Y=-1 W !,"error creating note entry" D PAUSE,EXIT Q
W !
S AMHNIEN=+Y
S DIE="^AMHPTP(",DA=AMHNIEN,DR=".04;.06//^S X=$P(^VA(200,DUZ,0),U);.07" D ^DIE K DIE,DR,DA
G NO ; D EXIT
Q
DELADD ;
S AMHDEL=0
W !!,"Problem list entry is incomplete, it will be deleted."
W ! S DIR(0)="Y",DIR("A")="Are you sure you want to delete this BH Problem",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) Q
I 'Y Q
S AMHDEL=1
Q
EDIT ;EP - called from protocol to modify a problem on problem list
NEW AMHPIEN,AMHTEMP,AMHOLDS,AMHOLDD,AMHNEWC
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
S AMHOLDS=$P(^AMHPPROB(AMHPIEN,0),U,12)
S AMHOLDD=$P(^AMHPPROB(AMHPIEN,0),U,1)
S AMHTEMP="[AMH MODIFY PROBLEM]"
W:$D(IOF) @IOF W !,"Editing Problem ... ",!!
;CALL READER FOR .01 AND DO NOT ALLOW @
S DIR(0)="9002011.51,.01",DIR("A")="Diagnosis",DIR("B")=$P(^AMHPROB(AMHOLDD,0),U,1) KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"^ing out...no editing logged." D PAUSE,EXIT Q
S AMHNEWC=+Y
I 'AMHNEWC S AMHNEWC=$P(^AMHPPROB(AMHPIEN,0),U,1)
S DA=AMHPIEN,DIE="^AMHPPROB(",DR=".01////"_AMHNEWC_";.03////"_$$NOW^XLFDT,DIE("NO^")=1 D ^DIE K DA,DIE,DR
;D DIE
;
I $P(^AMHPPROB(AMHPIEN,0),U,1)'=AMHOLDD S DIE="^AMHPPROB(",DA=AMHPIEN,DR=".05///"_$P(^AMHPROB($P(^AMHPPROB(DA,0),U,1),0),U,2) D ^DIE K DA,DIE,DR
D DIE
I $P(^AMHPPROB(AMHPIEN,0),U,12)="D" D DELMOD
S DA=AMHPIEN
D PLUDE^AMHAPRB(AMHPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I"))
D EXIT
Q
DELMOD ;
;
W !!,"Please Note: You are NOT permitted to delete a BH Problem without",!,"entering a reason for the deletion."
W ! S DIR(0)="Y",DIR("A")="Are you sure you want to delete this BH Problem",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) K DIE,DR,DA S DIE="^AMHPPROB(",DR=".12///"_AMHOLDS,DA=AMHPIEN D ^DIE K DIE,DA,DR W !,"okay, not deleted. status changed back to "_$$VAL^XBDIQ1(9002011.51,AMHPIEN,.12) D PAUSE Q
I 'Y K DIE,DR,DA S DIE="^AMHPPROB(",DR=".12///"_AMHOLDS,DA=AMHPIEN D ^DIE K DIE,DA,DR W !,"okay, not deleted. status changed back to "_$$VAL^XBDIQ1(9002011.51,AMHPIEN,.12) D PAUSE Q
S DIR(0)="9002011.51,2.01",DIR("A")="Enter the Provider who deleted the Problem"
S DIR("B")=$S($G(AMHR):$$PRIMPROV^AMHUTIL(AMHR,"N"),1:"") KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." K DIE,DR,DA S DIE="^AMHPPROB(",DR=".12///"_AMHOLDS,DA=AMHPIEN D ^DIE K DIE,DA,DR W !," Problem not deleted. status changed back to "_$$VAL^XBDIQ1(9002011.51,AMHPIEN,.12) D PAUSE Q
S AMHPRV=+Y
S DA=AMHPIEN,DR="[AMH DELETE PROBLEM]",DIE="^AMHPPROB(" D ^DIE K DA,DIE,DR
W !
Q
DEL ;EP - called from protocol to delete a problem on problem list
NEW AMHPIEN,ANHPRV
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
W:$D(IOF) @IOF
W !!,"Deleting the following BH Problem from ",$P($P(^DPT(AMHPAT,0),U),",",2)," ",$P($P(^(0),U),","),"'s BH Problem List.",!
S DA=AMHPIEN,DIC="^AMHPPROB(" D EN^DIQ
;
W !!,"Please Note: You are NOT permitted to delete a BH Problem without",!,"entering a reason for the deletion."
W ! S DIR(0)="Y",DIR("A")="Are you sure you want to delete this BH Problem",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) W !,"okay, not deleted." D PAUSE,EXIT Q
I 'Y W !,"Okay, not deleted." D PAUSE,EXIT Q
S DIR(0)="9002011.51,2.01",DIR("A")="Enter the Provider who deleted the Problem"
S DIR("B")=$S($G(AMHR):$$PRIMPROV^AMHUTIL(AMHR,"N"),1:"") KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." D PAUSE,EXIT Q
S AMHPRV=+Y
S DA=AMHPIEN,DR="[AMH DELETE PROBLEM]",DIE="^AMHPPROB(" D ^DIE K DA,DIE,DR
W !
S DA=AMHPIEN
D PLUDE^AMHAPRB(AMHPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I"))
D PAUSE,EXIT,^XBFMK
Q
AN ;EP - add a note, called from protocol
NEW AMHPIEN
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
D NO1^AMHBPL2
D EXIT,^XBFMK
Q
MN ;EP - called from protocol to modify a note
NEW AMHPIEN
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
D MN1^AMHBPL2
D PAUSE,EXIT,^XBFMK
Q
RNO ;EP - called from protocol to remove a note
NEW AMHPIEN
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
D RNO1^AMHBPL2
D PAUSE,EXIT
Q
ACT ;EP - called from protocol to activate an inactive problem
NEW AMHPIEN,AMHNDT
S AMHNDT=$P(AMHDATE,".")
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
I $P(^AMHPPROB(AMHPIEN,0),U,12)="A" W !!,"That problem is already ACTIVE!!" D PAUSE,EXIT Q
S AMHTEMP=".12///A;.03////^S X=$$NOW^XLFDT;.15////^S X=DUZ"
W:$D(IOF) @IOF W !,"Activating BH Problem ... "
D DIE
S DA=AMHPIEN
D PLUDE^AMHAPRB(AMHPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I"))
D EXIT
Q
INACT ;EP - called from protocol to inactivate an active problem
NEW AMHPIEN,AMHNDT
S AMHNDT=$P(AMHDATE,".")
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
I $P(^AMHPPROB(AMHPIEN,0),U,12)="I" W !!,"That BH Problem is already INACTIVE!!",! D PAUSE,EXIT Q
S AMHTEMP=".12///I;.03////^S X=$$NOW^XLFDT;.15////^S X=DUZ"
W:$D(IOF) @IOF W !,"Inactivating BH Problem ... "
D DIE
S DA=AMHPIEN
D PLUDE^AMHAPRB(AMHPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I"))
D EXIT
Q
HS ;EP - called from protocol to display health summary
NEW AMHHDR
D FULL^VALM1
S X="" I DUZ(2),$D(^APCCCTRL(DUZ(2),0))#2 S X=$P(^(0),U,3) I X,$D(^APCHSCTL(X,0)) S X=$P(^APCHSCTL(X,0),U)
I $D(^DISV(DUZ,"^APCHSCTL(")) S Y=^("^APCHSCTL(") I $D(^APCHSCTL(Y,0)) S X=$P(^(0),U,1)
S:X="" X="ADULT REGULAR"
K DIC,DR,DD S DIC("B")=X,DIC="^APCHSCTL(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DD,D0,D1,DQ
I Y=-1 D PAUSE,EXIT Q
S APCHSTYP=+Y,APCHSPAT=AMHPAT
S AMHHDR="PCC Health Summary for "_$P(^DPT(AMHBPLPT,0),U)
D VIEWR^XBLM("EN^APCHS",AMHHDR)
S (DFN,Y)=AMHPAT D ^AUPNPAT
K APCHSPAT,APCHSTYP,APCHSTAT,APCHSMTY,AMCHDAYS,AMCHDOB,AMHHDR
D EXIT
Q
DD ;EP - called from protocol to display (DIQ) a problem in detail
NEW AMHPIEN,AMHTNDF,AMHTN,AMHTDOI,AMHTTPT,AMHTNRQ,AMHAUTH
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
D VIEWR^XBLM("DD1^AMHBPL1","Behavioral Health Problem Display")
D EXIT
Q
DD1 ;
;S DA=AMHPIEN,DIC="^AMHPPROB(" D EN^DIQ
NEW AMHAR,F,AMHH,AMHZ D ENP^XBDIQ1(9002011.51,AMHPIEN,".01:.13;.15:999999","AMHAR(","E")
S F=0 F S F=$O(AMHAR(F)) Q:F'=+F I AMHAR(F)]"" D
.S AMHH=$P(^DD(9002011.51,F,0),U)
.S AMHZ=AMHAR(F)
.W !,$E(AMHH,1,25),":",?30,AMHZ
;
DDN ;EP
K AMHNOTES
S AMHC=0
Q:'$D(^AMHPTP("AE",AMHPIEN))
W !,"Notes: "
S AMHTNDF=0 F AMHTQ=0:0 S AMHTNDF=$O(^AMHPTP("AE",AMHPIEN,AMHTNDF)) Q:'AMHTNDF D DSPN
Q
DSPN ; DISPLAY SINGLE NOTE
S X=$O(^AMHPTP("AE",AMHPIEN,AMHTNDF,"")) Q:X=""
S AMHC=AMHC+1
S AMHTN=^AMHPTP(X,0)
S AMHTDOI=$P(AMHTN,U,5) I AMHTDOI]"" S AMHTDOI=$$DATE^AMHVRL(AMHTDOI)
S AMHTTPT=$$VAL^XBDIQ1(9002011.53,X,.07) ;$P(AMHTN,U,7) S AMHTTPT=$S(AMHTTPT=1:"STP",AMHTTPT=2:"LTP",1:" ")
S AMHAUTH=$$VAL^XBDIQ1(9002011.53,X,.06)
W !!?3,AMHC,")",?7,"Date Added: ",AMHTDOI,?30,"Author: "_AMHAUTH
W !?3,"Note Narrative: "_$$VAL^XBDIQ1(9002011.53,X,.04)
I AMHTTPT]"" W !?3,AMHTTPT_" TERM TREATMENT"
S AMHNOTES(AMHC)=X
Q
FS ;EP -called from protcol to display face sheet
D FULL^VALM1
S AMHHDR="Demographic Face Sheet For "_$P(^DPT(AMHPAT,0),U)
D VIEWR^XBLM("START^AGFACE",AMHHDR)
K AGOPT,AGDENT,AGMVDF,AMHHDR
D EXIT
Q
PAUSE ;EP
S DIR(0)="EO",DIR("A")="Press return to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
GETNUM(P) ;EP - get problem number given ien of problem entry
NEW N,F
S N=""
I 'P Q N
I '$D(^AMHPPROB(P,0)) Q N
S F=$P(^AMHPPROB(P,0),U,6)
S N=$S($P(^AUTTLOC(F,0),U,7)]"":$J($P(^(0),U,7),4),1:"??")_$P(^AMHPPROB(P,0),U,7)
Q N
EXIT ;EP
D TERM^VALM0
S VALMBCK="R"
D GATHER^AMHBPL
S VALMCNT=AMHLINE
D HDR^AMHBPL
K AMHTEMP,AMHPRMT,AMHP,AMHPIEN,AMHAF,AMHF,AMHP0,AMHPRB
D KDIE
Q
LBLK(V,L) ;left blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
Q V
AMHBPL1 ; IHS/CMI/LAB - problem list update from list manager ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**2,4**;JUN 18, 2010;Build 28
+2 ;
+3 ;
DIE ;
+1 SET DIE("NO^")=1
+2 SET DA=AMHPIEN
SET DIE="^AMHPPROB("
SET DR=AMHTEMP
DO ^DIE
KDIE ;kill all vars used by DIE
+1 KILL DIE,DR,DA,DIU,DIV,DQ,D0,DO,DI,DIW,DIY,%,DQ,DLAYGO
+2 QUIT
GETPROB ;EP - get record
+1 SET AMHPIEN=0
+2 IF 'AMHPRCNT
WRITE !!,"No problems to select"
QUIT
+3 SET DIR(0)="N^1:"_AMHPRCNT_":0"
SET DIR("A")="Select Problem"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
WRITE !!,"No Problem Selected"
QUIT
+5 SET AMHP=Y
+6 SET (X,Y)=0
FOR
SET X=$ORDER(AMHBHPL("IDX",X))
IF X'=+X!(AMHPIEN)
QUIT
IF $ORDER(AMHBHPL("IDX",X,0))=AMHP
SET Y=$ORDER(AMHBHPL("IDX",X,0))
SET AMHPIEN=AMHBHPL("IDX",X,Y)
+7 IF '$DATA(^AMHPPROB(AMHPIEN,0))
WRITE !,"Not a valid BEHAVIORAL HEALTH PROBLEM."
KILL AMHP
SET AMHPIEN=0
QUIT
+8 ;give me full control of screen
DO FULL^VALM1
+9 QUIT
ADD ;EP - called from protocol to add a problem to problem list
+1 ; this gives me back all screen control
DO FULL^VALM1
+2 IF $DATA(IOF)
WRITE @IOF
WRITE !!!,"Adding a new BH Problem for ",$PIECE(^DPT(AMHBPLPT,0),U),".",!!
+3 WRITE "Purpose of Visit Diagnoses assigned to this patient in the past 90 days:",!
+4 NEW AMHPOVS,X,Y,N,AMHC,AMHOTH,D,P,AMHANS,AMHNUM,AMHTY,AMHNNUM,AMHNIEN,AMHCODE,AMHPOVS1,AMHANS,AMHOTH,AMHAPIEN,AMHNARR
+5 SET AMHC=0
+6 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AC",AMHPAT,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 IF '$DATA(^AMHRPRO(X,0))
QUIT
+8 SET D=$PIECE(^AMHRPRO(X,0),U,3)
+9 SET D=$PIECE($PIECE($GET(^AMHREC(D,0)),U,1),".")
+10 IF D<$$FMADD^XLFDT(DT,-91)
QUIT
+11 SET Y=$$VAL^XBDIQ1(9002011.01,X,.01)
+12 SET I=$PIECE(^AMHRPRO(X,0),U,1)
+13 SET N=$$VAL^XBDIQ1(9002012.2,$$VALI^XBDIQ1(9002011.01,X,.01),.02)
+14 SET P=$$VAL^XBDIQ1(9002011.01,X,.04)
+15 SET AMHPOVS(Y)=N_U_P_U_Y_U_I
End DoDot:1
+16 SET Y=""
FOR
SET Y=$ORDER(AMHPOVS(Y))
IF Y=""
QUIT
Begin DoDot:1
+17 SET AMHC=AMHC+1
+18 WRITE $$LBLK(AMHC,3),") ",Y,?15,$PIECE(AMHPOVS(Y),U,1),!
+19 SET AMHPOVS1(AMHC)=AMHPOVS(Y)
End DoDot:1
+20 SET AMHC=AMHC+1
SET AMHOTH=AMHC
+21 WRITE $$LBLK(AMHC,3),") ","Any Other Diagnosis",!
+22 SET DIR(0)="NO^1:"_AMHC_":0"
SET DIR("A")="Choose a Diagnosis"
SET DIR("B")=AMHC
KILL DA
DO ^DIR
KILL DIR
+23 IF $DATA(DIRUT)
WRITE !!,"No diagnosis selected. "
DO PAUSE
DO EXIT
QUIT
+24 SET AMHANS=Y
+25 IF AMHANS'=AMHOTH
SET AMHCODE=$PIECE(AMHPOVS1(AMHANS),U,4)
GOTO ADD1
+26 SET AMHCODE=""
+27 WRITE !!
+28 SET DIR(0)="9002011.01,.01"
SET DIR("A")="Enter Diagnosis to Add to the Problem List"
KILL DA
DO ^DIR
KILL DIR
+29 IF $DATA(DIRUT)
WRITE !!,"No diagnosis selected. "
DO PAUSE
DO EXIT
QUIT
+30 SET AMHCODE=+Y
ADD1 ;
+1 KILL DD,D0,DO,DINUM,DIC,DA,DR,DIADD
+2 SET AMHNUM=0
SET AMHTY=""
FOR
SET AMHTY=$ORDER(^AMHPPROB("AA",AMHPAT,AMHTY))
IF AMHTY=""
QUIT
Begin DoDot:1
+3 SET AMHNUM=$EXTRACT(AMHTY,2,4)
SET AMHNUM=AMHNUM+1
End DoDot:1
+4 IF AMHNUM=0
SET AMHNUM=1
+5 SET AMHNUM=+AMHNUM
+6 SET DIC(0)="EL"
SET DIC="^AMHPPROB("
SET DLAYGO=9002011.51
SET DIADD=1
SET X=AMHCODE
+7 SET DIC("DR")=".02////"_AMHPAT_";.03////"_$$NOW^XLFDT_";.06////"_DUZ(2)_";.07////"_AMHNUM_";.08////"_$$NOW^XLFDT_";.15////"_DUZ
+8 DO FILE^DICN
KILL DIC,DR,DIE,DIADD,DLAYGO,X,D0
+9 IF Y=-1
WRITE !!,"error generating problem entry"
DO PAUSE
DO EXIT
QUIT
+10 SET AMHAPIEN=+Y
+11 SET AMHNARR=$PIECE(^AMHPROB(AMHCODE,0),U,2)
+12 SET APCDOVRR=1
SET AMHOVRR=1
+13 SET DIE("NO^")=1
SET DIE="^AMHPPROB("
SET DR=".05//"_AMHNARR
SET DA=AMHAPIEN
DO ^DIE
DO KDIE
STAT ;get status value
+1 KILL DIR
SET DIR(0)="S^A:ACTIVE;I:INACTIVE"
SET DIR("A")="STATUS"
SET DIR("B")="ACTIVE"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
WRITE !!,"This is a required response. "
DO DELADD
IF 'AMHDEL
GOTO STAT
SET DA=AMHAPIEN
SET DIK="^AMHPPROB("
DO ^DIK
KILL DA,DIK
DO PAUSE
DO EXIT
QUIT
+3 IF Y'="I"
IF Y'="A"
WRITE !!,"This is a required response, must be A or I, ""^"" to exit and delete the problem."
GOTO STAT
+4 SET AMHANS=Y
+5 SET DIE="^AMHPPROB("
SET DR=".12////"_AMHANS_";.13"
SET DA=AMHAPIEN
DO ^DIE
DO KDIE
NO ;
+1 WRITE !!
+2 SET DIR(0)="Y"
SET DIR("A")="Add TREATMENT Note"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
DO PLUDE^AMHAPRB(AMHAPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I"))
DO EXIT
QUIT
+4 IF 'Y
DO PLUDE^AMHAPRB(AMHAPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I"))
DO EXIT
QUIT
+5 SET AMHNNUM=$$GETNUM^AMHLETN(AMHAPIEN)
+6 WRITE !
+7 SET DIC="^AMHPTP("
SET X=AMHNNUM
SET DIC("DR")=".02////"_AMHPAT_";.03////"_AMHAPIEN_";.05////"_DT
SET DIADD=1
SET DLAYGO=9002011.53
SET DIC(0)="EL"
+8 DO FILE^DICN
+9 KILL DLAYGO,DIADD,DIC,DA
+10 IF Y=-1
WRITE !,"error creating note entry"
DO PAUSE
DO EXIT
QUIT
+11 WRITE !
+12 SET AMHNIEN=+Y
+13 SET DIE="^AMHPTP("
SET DA=AMHNIEN
SET DR=".04;.06//^S X=$P(^VA(200,DUZ,0),U);.07"
DO ^DIE
KILL DIE,DR,DA
+14 ; D EXIT
GOTO NO
+15 QUIT
DELADD ;
+1 SET AMHDEL=0
+2 WRITE !!,"Problem list entry is incomplete, it will be deleted."
+3 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this BH Problem"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF $DATA(DIRUT)
QUIT
+5 IF 'Y
QUIT
+6 SET AMHDEL=1
+7 QUIT
EDIT ;EP - called from protocol to modify a problem on problem list
+1 NEW AMHPIEN,AMHTEMP,AMHOLDS,AMHOLDD,AMHNEWC
+2 DO GETPROB
+3 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+4 SET AMHOLDS=$PIECE(^AMHPPROB(AMHPIEN,0),U,12)
+5 SET AMHOLDD=$PIECE(^AMHPPROB(AMHPIEN,0),U,1)
+6 SET AMHTEMP="[AMH MODIFY PROBLEM]"
+7 IF $DATA(IOF)
WRITE @IOF
WRITE !,"Editing Problem ... ",!!
+8 ;CALL READER FOR .01 AND DO NOT ALLOW @
+9 SET DIR(0)="9002011.51,.01"
SET DIR("A")="Diagnosis"
SET DIR("B")=$PIECE(^AMHPROB(AMHOLDD,0),U,1)
KILL DA
DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
WRITE !!,"^ing out...no editing logged."
DO PAUSE
DO EXIT
QUIT
+11 SET AMHNEWC=+Y
+12 IF 'AMHNEWC
SET AMHNEWC=$PIECE(^AMHPPROB(AMHPIEN,0),U,1)
+13 SET DA=AMHPIEN
SET DIE="^AMHPPROB("
SET DR=".01////"_AMHNEWC_";.03////"_$$NOW^XLFDT
SET DIE("NO^")=1
DO ^DIE
KILL DA,DIE,DR
+14 ;D DIE
+15 ;
+16 IF $PIECE(^AMHPPROB(AMHPIEN,0),U,1)'=AMHOLDD
SET DIE="^AMHPPROB("
SET DA=AMHPIEN
SET DR=".05///"_$PIECE(^AMHPROB($PIECE(^AMHPPROB(DA,0),U,1),0),U,2)
DO ^DIE
KILL DA,DIE,DR
+17 DO DIE
+18 IF $PIECE(^AMHPPROB(AMHPIEN,0),U,12)="D"
DO DELMOD
+19 SET DA=AMHPIEN
+20 DO PLUDE^AMHAPRB(AMHPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I"))
+21 DO EXIT
+22 QUIT
DELMOD ;
+1 ;
+2 WRITE !!,"Please Note: You are NOT permitted to delete a BH Problem without",!,"entering a reason for the deletion."
+3 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this BH Problem"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF $DATA(DIRUT)
KILL DIE,DR,DA
SET DIE="^AMHPPROB("
SET DR=".12///"_AMHOLDS
SET DA=AMHPIEN
DO ^DIE
KILL DIE,DA,DR
WRITE !,"okay, not deleted. status changed back to "_$$VAL^XBDIQ1(9002011.51,AMHPIEN,.12)
DO PAUSE
QUIT
+5 IF 'Y
KILL DIE,DR,DA
SET DIE="^AMHPPROB("
SET DR=".12///"_AMHOLDS
SET DA=AMHPIEN
DO ^DIE
KILL DIE,DA,DR
WRITE !,"okay, not deleted. status changed back to "_$$VAL^XBDIQ1(9002011.51,AMHPIEN,.12)
DO PAUSE
QUIT
+6 SET DIR(0)="9002011.51,2.01"
SET DIR("A")="Enter the Provider who deleted the Problem"
+7 SET DIR("B")=$SELECT($GET(AMHR):$$PRIMPROV^AMHUTIL(AMHR,"N"),1:"")
KILL DA
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
WRITE !!,"This is required."
KILL DIE,DR,DA
SET DIE="^AMHPPROB("
SET DR=".12///"_AMHOLDS
SET DA=AMHPIEN
DO ^DIE
KILL DIE,DA,DR
WRITE !," Problem not deleted. status changed back to "_$$VAL^XBDIQ1(9002011.51,AMHPIEN,.12)
DO PAUSE
QUIT
+9 SET AMHPRV=+Y
+10 SET DA=AMHPIEN
SET DR="[AMH DELETE PROBLEM]"
SET DIE="^AMHPPROB("
DO ^DIE
KILL DA,DIE,DR
+11 WRITE !
+12 QUIT
DEL ;EP - called from protocol to delete a problem on problem list
+1 NEW AMHPIEN,ANHPRV
+2 DO GETPROB
+3 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+4 IF $DATA(IOF)
WRITE @IOF
+5 WRITE !!,"Deleting the following BH Problem from ",$PIECE($PIECE(^DPT(AMHPAT,0),U),",",2)," ",$PIECE($PIECE(^(0),U),","),"'s BH Problem List.",!
+6 SET DA=AMHPIEN
SET DIC="^AMHPPROB("
DO EN^DIQ
+7 ;
+8 WRITE !!,"Please Note: You are NOT permitted to delete a BH Problem without",!,"entering a reason for the deletion."
+9 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this BH Problem"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+10 IF $DATA(DIRUT)
WRITE !,"okay, not deleted."
DO PAUSE
DO EXIT
QUIT
+11 IF 'Y
WRITE !,"Okay, not deleted."
DO PAUSE
DO EXIT
QUIT
+12 SET DIR(0)="9002011.51,2.01"
SET DIR("A")="Enter the Provider who deleted the Problem"
+13 SET DIR("B")=$SELECT($GET(AMHR):$$PRIMPROV^AMHUTIL(AMHR,"N"),1:"")
KILL DA
DO ^DIR
KILL DIR
+14 IF $DATA(DIRUT)
WRITE !!,"This is required."
DO PAUSE
DO EXIT
QUIT
+15 SET AMHPRV=+Y
+16 SET DA=AMHPIEN
SET DR="[AMH DELETE PROBLEM]"
SET DIE="^AMHPPROB("
DO ^DIE
KILL DA,DIE,DR
+17 WRITE !
+18 SET DA=AMHPIEN
+19 DO PLUDE^AMHAPRB(AMHPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I"))
+20 DO PAUSE
DO EXIT
DO ^XBFMK
+21 QUIT
AN ;EP - add a note, called from protocol
+1 NEW AMHPIEN
+2 DO GETPROB
+3 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+4 DO NO1^AMHBPL2
+5 DO EXIT
DO ^XBFMK
+6 QUIT
MN ;EP - called from protocol to modify a note
+1 NEW AMHPIEN
+2 DO GETPROB
+3 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+4 DO MN1^AMHBPL2
+5 DO PAUSE
DO EXIT
DO ^XBFMK
+6 QUIT
RNO ;EP - called from protocol to remove a note
+1 NEW AMHPIEN
+2 DO GETPROB
+3 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+4 DO RNO1^AMHBPL2
+5 DO PAUSE
DO EXIT
+6 QUIT
ACT ;EP - called from protocol to activate an inactive problem
+1 NEW AMHPIEN,AMHNDT
+2 SET AMHNDT=$PIECE(AMHDATE,".")
+3 DO GETPROB
+4 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+5 IF $PIECE(^AMHPPROB(AMHPIEN,0),U,12)="A"
WRITE !!,"That problem is already ACTIVE!!"
DO PAUSE
DO EXIT
QUIT
+6 SET AMHTEMP=".12///A;.03////^S X=$$NOW^XLFDT;.15////^S X=DUZ"
+7 IF $DATA(IOF)
WRITE @IOF
WRITE !,"Activating BH Problem ... "
+8 DO DIE
+9 SET DA=AMHPIEN
+10 DO PLUDE^AMHAPRB(AMHPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I"))
+11 DO EXIT
+12 QUIT
INACT ;EP - called from protocol to inactivate an active problem
+1 NEW AMHPIEN,AMHNDT
+2 SET AMHNDT=$PIECE(AMHDATE,".")
+3 DO GETPROB
+4 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+5 IF $PIECE(^AMHPPROB(AMHPIEN,0),U,12)="I"
WRITE !!,"That BH Problem is already INACTIVE!!",!
DO PAUSE
DO EXIT
QUIT
+6 SET AMHTEMP=".12///I;.03////^S X=$$NOW^XLFDT;.15////^S X=DUZ"
+7 IF $DATA(IOF)
WRITE @IOF
WRITE !,"Inactivating BH Problem ... "
+8 DO DIE
+9 SET DA=AMHPIEN
+10 DO PLUDE^AMHAPRB(AMHPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I"))
+11 DO EXIT
+12 QUIT
HS ;EP - called from protocol to display health summary
+1 NEW AMHHDR
+2 DO FULL^VALM1
+3 SET X=""
IF DUZ(2)
IF $DATA(^APCCCTRL(DUZ(2),0))#2
SET X=$PIECE(^(0),U,3)
IF X
IF $DATA(^APCHSCTL(X,0))
SET X=$PIECE(^APCHSCTL(X,0),U)
+4 IF $DATA(^DISV(DUZ,"^APCHSCTL("))
SET Y=^("^APCHSCTL(")
IF $DATA(^APCHSCTL(Y,0))
SET X=$PIECE(^(0),U,1)
+5 IF X=""
SET X="ADULT REGULAR"
+6 KILL DIC,DR,DD
SET DIC("B")=X
SET DIC="^APCHSCTL("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DD,D0,D1,DQ
+7 IF Y=-1
DO PAUSE
DO EXIT
QUIT
+8 SET APCHSTYP=+Y
SET APCHSPAT=AMHPAT
+9 SET AMHHDR="PCC Health Summary for "_$PIECE(^DPT(AMHBPLPT,0),U)
+10 DO VIEWR^XBLM("EN^APCHS",AMHHDR)
+11 SET (DFN,Y)=AMHPAT
DO ^AUPNPAT
+12 KILL APCHSPAT,APCHSTYP,APCHSTAT,APCHSMTY,AMCHDAYS,AMCHDOB,AMHHDR
+13 DO EXIT
+14 QUIT
DD ;EP - called from protocol to display (DIQ) a problem in detail
+1 NEW AMHPIEN,AMHTNDF,AMHTN,AMHTDOI,AMHTTPT,AMHTNRQ,AMHAUTH
+2 DO GETPROB
+3 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+4 DO VIEWR^XBLM("DD1^AMHBPL1","Behavioral Health Problem Display")
+5 DO EXIT
+6 QUIT
DD1 ;
+1 ;S DA=AMHPIEN,DIC="^AMHPPROB(" D EN^DIQ
+2 NEW AMHAR,F,AMHH,AMHZ
DO ENP^XBDIQ1(9002011.51,AMHPIEN,".01:.13;.15:999999","AMHAR(","E")
+3 SET F=0
FOR
SET F=$ORDER(AMHAR(F))
IF F'=+F
QUIT
IF AMHAR(F)]""
Begin DoDot:1
+4 SET AMHH=$PIECE(^DD(9002011.51,F,0),U)
+5 SET AMHZ=AMHAR(F)
+6 WRITE !,$EXTRACT(AMHH,1,25),":",?30,AMHZ
End DoDot:1
+7 ;
DDN ;EP
+1 KILL AMHNOTES
+2 SET AMHC=0
+3 IF '$DATA(^AMHPTP("AE",AMHPIEN))
QUIT
+4 WRITE !,"Notes: "
+5 SET AMHTNDF=0
FOR AMHTQ=0:0
SET AMHTNDF=$ORDER(^AMHPTP("AE",AMHPIEN,AMHTNDF))
IF 'AMHTNDF
QUIT
DO DSPN
+6 QUIT
DSPN ; DISPLAY SINGLE NOTE
+1 SET X=$ORDER(^AMHPTP("AE",AMHPIEN,AMHTNDF,""))
IF X=""
QUIT
+2 SET AMHC=AMHC+1
+3 SET AMHTN=^AMHPTP(X,0)
+4 SET AMHTDOI=$PIECE(AMHTN,U,5)
IF AMHTDOI]""
SET AMHTDOI=$$DATE^AMHVRL(AMHTDOI)
+5 ;$P(AMHTN,U,7) S AMHTTPT=$S(AMHTTPT=1:"STP",AMHTTPT=2:"LTP",1:" ")
SET AMHTTPT=$$VAL^XBDIQ1(9002011.53,X,.07)
+6 SET AMHAUTH=$$VAL^XBDIQ1(9002011.53,X,.06)
+7 WRITE !!?3,AMHC,")",?7,"Date Added: ",AMHTDOI,?30,"Author: "_AMHAUTH
+8 WRITE !?3,"Note Narrative: "_$$VAL^XBDIQ1(9002011.53,X,.04)
+9 IF AMHTTPT]""
WRITE !?3,AMHTTPT_" TERM TREATMENT"
+10 SET AMHNOTES(AMHC)=X
+11 QUIT
FS ;EP -called from protcol to display face sheet
+1 DO FULL^VALM1
+2 SET AMHHDR="Demographic Face Sheet For "_$PIECE(^DPT(AMHPAT,0),U)
+3 DO VIEWR^XBLM("START^AGFACE",AMHHDR)
+4 KILL AGOPT,AGDENT,AGMVDF,AMHHDR
+5 DO EXIT
+6 QUIT
PAUSE ;EP
+1 SET DIR(0)="EO"
SET DIR("A")="Press return to continue...."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 QUIT
GETNUM(P) ;EP - get problem number given ien of problem entry
+1 NEW N,F
+2 SET N=""
+3 IF 'P
QUIT N
+4 IF '$DATA(^AMHPPROB(P,0))
QUIT N
+5 SET F=$PIECE(^AMHPPROB(P,0),U,6)
+6 SET N=$SELECT($PIECE(^AUTTLOC(F,0),U,7)]"":$JUSTIFY($PIECE(^(0),U,7),4),1:"??")_$PIECE(^AMHPPROB(P,0),U,7)
+7 QUIT N
EXIT ;EP
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO GATHER^AMHBPL
+4 SET VALMCNT=AMHLINE
+5 DO HDR^AMHBPL
+6 KILL AMHTEMP,AMHPRMT,AMHP,AMHPIEN,AMHAF,AMHF,AMHP0,AMHPRB
+7 DO KDIE
+8 QUIT
LBLK(V,L) ;left blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=" "_V
+3 QUIT V
