AMHPL2 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
;;4.0;IHS BEHAVIORAL HEALTH;**2**;JUN 18, 2010;Build 23
;
NO1 ;EP
W:$D(IOF) @IOF
W !!,"Adding a Note to the following problem on ",$P($P(^DPT(DFN,0),U),",",2)," ",$P($P(^(0),U),","),"'s Problem List.",!
S (X,D)=0 F S X=$O(^TMP($J,"AMHPL","IDX",X)) Q:X'=+X!D S Y=$O(^TMP($J,"AMHPL","IDX",X,0)) S:Y>AMHPIEN D=1 I ^TMP($J,"AMHPL","IDX",X,Y)=AMHPIEN W !,^TMP($J,"AMHPL",X,0)
I $O(^AUPNPROB(AMHPIEN,11,0)) D
.W !!?6,IORVON,"Problem Notes: ",IORVOFF S L=0 F S L=$O(^AUPNPROB(AMHPIEN,11,L)) Q:L'=+L I $O(^AUPNPROB(AMHPIEN,11,L,11,0)) W !?6,$P(^DIC(4,$P(^AUPNPROB(AMHPIEN,11,L,0),U),0),U) D
..S X=0 F S X=$O(^AUPNPROB(AMHPIEN,11,L,11,X)) Q:X'=+X W !?8,"Note#",$P(^AUPNPROB(AMHPIEN,11,L,11,X,0),U)," ",$$FMTE^XLFDT($P(^(0),U,5),5),?30,$P(^AUPNPROB(AMHPIEN,11,L,11,X,0),U,3)
W ! S DIR(0)="Y",DIR("A")="Add a new Problem Note for this Problem",DIR("B")="Y" K DA D ^DIR K DIR
G:$D(DIRUT) NOX
G:Y=0 NOX
NUM ;
;add location multiple if necessary, otherwise get ien in multiple
S AMHNIEN=$O(^AUPNPROB(AMHPIEN,11,"B",$S($G(AMHLOC):AMHLOC,1:DUZ(2)),0))
I AMHNIEN="" S DIADD=9000011.11,X="`"_$S($G(AMHLOC):AMHLOC,1:DUZ(2)),DIC="^AUPNPROB("_AMHPIEN_",11,",DA(1)=AMHPIEN,DIC(0)="L",DIC("P")=$P(^DD(9000011,1101,0),U,2) D
.D ^DIC K DIC,DA,DR,Y,DIADD,X S AMHNIEN=$O(^AUPNPROB(AMHPIEN,11,"B",$S($G(AMHLOC):AMHLOC,1:DUZ(2)),0))
I AMHNIEN="" W $C(7),$C(7),"ERROR UPDATING NOTE LOCATION MULTIPLE" G NOX
S (Y,X)=0 F S Y=$O(^AUPNPROB(AMHPIEN,11,AMHNIEN,11,"B",Y)) S:Y X=Y I 'Y S X=X+1 K Y Q
S AMHNUM=X
W !!,"Adding Note #",X
K DIC S X=AMHNUM,DA(1)=AMHNIEN,DA(2)=AMHPIEN,DIC="^AUPNPROB("_AMHPIEN_",11,"_AMHNIEN_",11,",DIC("P")=$P(^DD(9000011.11,1101,0),U,2),DIC(0)="L" D ^DIC K DA,DR,DIADD,DLAYGO,DD,DO,D0
I Y=-1 W !!,$C(7),$C(7),"ERROR when updating note number multiple",! G NOX
S DIE=DIC K DIC W ?8 S DA=+Y,DR=".03;.05////"_$S($G(AMHDATE)]"":$P(AMHDATE,"."),1:DT) D ^DIE K DIE,DR,DA,Y W !!
D ^XBFMK
K DIADD
D PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
G NO1
NOX ;
K Y,AMHPIEN,X,L,AMHNUM,AMHL,DIC,DA,DD,AMHC,AMHN,AMHNIEN,DR,DIADD
Q
RNO1 ;EP - called from AMHPL1 - remove a note
W:$D(IOF) @IOF
K AMHN,AMHL,AMHX,AMHC
W !!,"Removing a Note from the following problem on ",$P($P(^DPT(DFN,0),U),",",2)," ",$P($P(^(0),U),","),"'s Problem List.",!
S (X,D)=0 F S X=$O(^TMP($J,"AMHPL","IDX",X)) Q:X'=+X!D S Y=$O(^TMP($J,"AMHPL","IDX",X,0)) S:Y>AMHPIEN D=1 I ^TMP($J,"AMHPL","IDX",X,Y)=AMHPIEN W !,^TMP($J,"AMHPL",X,0)
S AMHC=0 I $O(^AUPNPROB(AMHPIEN,11,0)) D
.W !!?6,IORVON,"Problem Notes: ",IORVOFF S (AMHC,AMHL)=0 F S AMHL=$O(^AUPNPROB(AMHPIEN,11,AMHL)) Q:AMHL'=+AMHL I $O(^AUPNPROB(AMHPIEN,11,AMHL,11,0)) W !?6,$P(^DIC(4,$P(^AUPNPROB(AMHPIEN,11,AMHL,0),U),0),U) D
..S AMHX=0 F S AMHX=$O(^AUPNPROB(AMHPIEN,11,AMHL,11,AMHX)) Q:AMHX'=+AMHX D
...S AMHC=AMHC+1,AMHN(AMHC)=AMHL_U_AMHX W !?8,AMHC,") Note#",$P(^AUPNPROB(AMHPIEN,11,AMHL,11,AMHX,0),U)," ",$$FMTE^XLFDT($P(^(0),U,5),5),?30,$P(^AUPNPROB(AMHPIEN,11,AMHL,11,AMHX,0),U,3)
I AMHC=0 W !?8,"No note on file for this problem" G RNO1X
W ! K DIR S DIR(0)="N^1:"_AMHC_":",DIR("A")="Remove which one" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) W !,"Okay, bye." G RNO1X
I 'Y W !,"No Note selected" G RNO1X
S AMHY=+Y
RSURE ;
W !! S DIR(0)="Y",DIR("A")="Are you sure you want to delete this NOTE",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) W !,"okay, not deleted." G RNO1X
I 'Y W !,"Okay, not deleted." G RNO1X
S DA(1)=$P(AMHN(AMHY),U),DA(2)=AMHPIEN,DIE="^AUPNPROB("_AMHPIEN_",11,"_$P(AMHN(AMHY),U)_",11,",DIC("P")=$P(^DD(9000011.11,1101,0),U,2)
S DA=$P(AMHN(AMHY),U,2),DR=".01///@" D ^DIE K DIE,DR,DA,Y W !!
D PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
RNO1X ;xit
K AMHPIEN,AMHL,AMHX,AMHN,AMHY
Q
MN1 ;EP - called to modify a note
W:$D(IOF) @IOF
K AMHN,AMHL,AMHX,AMHC
W !!,"Editing a Note on the following problem on ",$P($P(^DPT(DFN,0),U),",",2)," ",$P($P(^(0),U),","),"'s Problem List.",!
S (X,D)=0 F S X=$O(^TMP($J,"AMHPL","IDX",X)) Q:X'=+X!D S Y=$O(^TMP($J,"AMHPL","IDX",X,0)) S:Y>AMHPIEN D=1 I ^TMP($J,"AMHPL","IDX",X,Y)=AMHPIEN W !,^TMP($J,"AMHPL",X,0)
S AMHC=0 I $O(^AUPNPROB(AMHPIEN,11,0)) D
.W !!?6,IORVON,"Problem Notes: ",IORVOFF S (AMHC,AMHL)=0 F S AMHL=$O(^AUPNPROB(AMHPIEN,11,AMHL)) Q:AMHL'=+AMHL I $O(^AUPNPROB(AMHPIEN,11,AMHL,11,0)) W !?6,$P(^DIC(4,$P(^AUPNPROB(AMHPIEN,11,AMHL,0),U),0),U) D
..S AMHX=0 F S AMHX=$O(^AUPNPROB(AMHPIEN,11,AMHL,11,AMHX)) Q:AMHX'=+AMHX D
...S AMHC=AMHC+1,AMHN(AMHC)=AMHL_U_AMHX W !?8,AMHC,") Note#",$P(^AUPNPROB(AMHPIEN,11,AMHL,11,AMHX,0),U)," ",$$FMTE^XLFDT($P(^(0),U,5),5),?30,$P(^AUPNPROB(AMHPIEN,11,AMHL,11,AMHX,0),U,3)
I AMHC=0 W !?8,"No notes on file for this problem" G RNO1X
W ! K DIR S DIR(0)="N^1:"_AMHC_":",DIR("A")="Edit which one" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) W !,"Okay, bye." G RNO1X
I 'Y W !,"No Note selected" G RNO1X
S AMHY=+Y
MSURE ;
S DA(1)=$P(AMHN(AMHY),U),DA(2)=AMHPIEN,DIE="^AUPNPROB("_AMHPIEN_",11,"_$P(AMHN(AMHY),U)_",11,",DIC("P")=$P(^DD(9000011.11,1101,0),U,2)
S DA=$P(AMHN(AMHY),U,2),DR=".01;.03" D ^DIE K DIE,DR,DA,Y W !!
D PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
MNO1X ;
K AMHPIEN,AMHL,AMHX,AMHN,AMHY
Q
AMHPL2 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**2**;JUN 18, 2010;Build 23
+2 ;
NO1 ;EP
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !!,"Adding a Note to the following problem on ",$PIECE($PIECE(^DPT(DFN,0),U),",",2)," ",$PIECE($PIECE(^(0),U),","),"'s Problem List.",!
+3 SET (X,D)=0
FOR
SET X=$ORDER(^TMP($JOB,"AMHPL","IDX",X))
IF X'=+X!D
QUIT
SET Y=$ORDER(^TMP($JOB,"AMHPL","IDX",X,0))
IF Y>AMHPIEN
SET D=1
IF ^TMP($JOB,"AMHPL","IDX",X,Y)=AMHPIEN
WRITE !,^TMP($JOB,"AMHPL",X,0)
+4 IF $ORDER(^AUPNPROB(AMHPIEN,11,0))
Begin DoDot:1
+5 WRITE !!?6,IORVON,"Problem Notes: ",IORVOFF
SET L=0
FOR
SET L=$ORDER(^AUPNPROB(AMHPIEN,11,L))
IF L'=+L
QUIT
IF $ORDER(^AUPNPROB(AMHPIEN,11,L,11,0))
WRITE !?6,$PIECE(^DIC(4,$PIECE(^AUPNPROB(AMHPIEN,11,L,0),U),0),U)
Begin DoDot:2
+6 SET X=0
FOR
SET X=$ORDER(^AUPNPROB(AMHPIEN,11,L,11,X))
IF X'=+X
QUIT
WRITE !?8,"Note#",$PIECE(^AUPNPROB(AMHPIEN,11,L,11,X,0),U)," ",$$FMTE^XLFDT($PIECE(^(0),U,5),5),?30,$PIECE(^AUPNPROB(AMHPIEN,11,L,11,X,0),U,3)
End DoDot:2
End DoDot:1
+7 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Add a new Problem Note for this Problem"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
GOTO NOX
+9 IF Y=0
GOTO NOX
NUM ;
+1 ;add location multiple if necessary, otherwise get ien in multiple
+2 SET AMHNIEN=$ORDER(^AUPNPROB(AMHPIEN,11,"B",$SELECT($GET(AMHLOC):AMHLOC,1:DUZ(2)),0))
+3 IF AMHNIEN=""
SET DIADD=9000011.11
SET X="`"_$SELECT($GET(AMHLOC):AMHLOC,1:DUZ(2))
SET DIC="^AUPNPROB("_AMHPIEN_",11,"
SET DA(1)=AMHPIEN
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9000011,1101,0),U,2)
Begin DoDot:1
+4 DO ^DIC
KILL DIC,DA,DR,Y,DIADD,X
SET AMHNIEN=$ORDER(^AUPNPROB(AMHPIEN,11,"B",$SELECT($GET(AMHLOC):AMHLOC,1:DUZ(2)),0))
End DoDot:1
+5 IF AMHNIEN=""
WRITE $CHAR(7),$CHAR(7),"ERROR UPDATING NOTE LOCATION MULTIPLE"
GOTO NOX
+6 SET (Y,X)=0
FOR
SET Y=$ORDER(^AUPNPROB(AMHPIEN,11,AMHNIEN,11,"B",Y))
IF Y
SET X=Y
IF 'Y
SET X=X+1
KILL Y
QUIT
+7 SET AMHNUM=X
+8 WRITE !!,"Adding Note #",X
+9 KILL DIC
SET X=AMHNUM
SET DA(1)=AMHNIEN
SET DA(2)=AMHPIEN
SET DIC="^AUPNPROB("_AMHPIEN_",11,"_AMHNIEN_",11,"
SET DIC("P")=$PIECE(^DD(9000011.11,1101,0),U,2)
SET DIC(0)="L"
DO ^DIC
KILL DA,DR,DIADD,DLAYGO,DD,DO,D0
+10 IF Y=-1
WRITE !!,$CHAR(7),$CHAR(7),"ERROR when updating note number multiple",!
GOTO NOX
+11 SET DIE=DIC
KILL DIC
WRITE ?8
SET DA=+Y
SET DR=".03;.05////"_$SELECT($GET(AMHDATE)]"":$PIECE(AMHDATE,"."),1:DT)
DO ^DIE
KILL DIE,DR,DA,Y
WRITE !!
+12 DO ^XBFMK
+13 KILL DIADD
+14 DO PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
+15 GOTO NO1
NOX ;
+1 KILL Y,AMHPIEN,X,L,AMHNUM,AMHL,DIC,DA,DD,AMHC,AMHN,AMHNIEN,DR,DIADD
+2 QUIT
RNO1 ;EP - called from AMHPL1 - remove a note
+1 IF $DATA(IOF)
WRITE @IOF
+2 KILL AMHN,AMHL,AMHX,AMHC
+3 WRITE !!,"Removing a Note from the following problem on ",$PIECE($PIECE(^DPT(DFN,0),U),",",2)," ",$PIECE($PIECE(^(0),U),","),"'s Problem List.",!
+4 SET (X,D)=0
FOR
SET X=$ORDER(^TMP($JOB,"AMHPL","IDX",X))
IF X'=+X!D
QUIT
SET Y=$ORDER(^TMP($JOB,"AMHPL","IDX",X,0))
IF Y>AMHPIEN
SET D=1
IF ^TMP($JOB,"AMHPL","IDX",X,Y)=AMHPIEN
WRITE !,^TMP($JOB,"AMHPL",X,0)
+5 SET AMHC=0
IF $ORDER(^AUPNPROB(AMHPIEN,11,0))
Begin DoDot:1
+6 WRITE !!?6,IORVON,"Problem Notes: ",IORVOFF
SET (AMHC,AMHL)=0
FOR
SET AMHL=$ORDER(^AUPNPROB(AMHPIEN,11,AMHL))
IF AMHL'=+AMHL
QUIT
IF $ORDER(^AUPNPROB(AMHPIEN,11,AMHL,11,0))
WRITE !?6,$PIECE(^DIC(4,$PIECE(^AUPNPROB(AMHPIEN,11,AMHL,0),U),0),U)
Begin DoDot:2
+7 SET AMHX=0
FOR
SET AMHX=$ORDER(^AUPNPROB(AMHPIEN,11,AMHL,11,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:3
+8 SET AMHC=AMHC+1
SET AMHN(AMHC)=AMHL_U_AMHX
WRITE !?8,AMHC,") Note#",$PIECE(^AUPNPROB(AMHPIEN,11,AMHL,11,AMHX,0),U)," ",$$FMTE^XLFDT($PIECE(^(0),U,5),5),?30,$PIECE(^AUPNPROB(AMHPIEN,11,AMHL,11,AMHX,0),U,3)
End DoDot:3
End DoDot:2
End DoDot:1
+9 IF AMHC=0
WRITE !?8,"No note on file for this problem"
GOTO RNO1X
+10 WRITE !
KILL DIR
SET DIR(0)="N^1:"_AMHC_":"
SET DIR("A")="Remove which one"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+11 IF $DATA(DIRUT)
WRITE !,"Okay, bye."
GOTO RNO1X
+12 IF 'Y
WRITE !,"No Note selected"
GOTO RNO1X
+13 SET AMHY=+Y
RSURE ;
+1 WRITE !!
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this NOTE"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
WRITE !,"okay, not deleted."
GOTO RNO1X
+3 IF 'Y
WRITE !,"Okay, not deleted."
GOTO RNO1X
+4 SET DA(1)=$PIECE(AMHN(AMHY),U)
SET DA(2)=AMHPIEN
SET DIE="^AUPNPROB("_AMHPIEN_",11,"_$PIECE(AMHN(AMHY),U)_",11,"
SET DIC("P")=$PIECE(^DD(9000011.11,1101,0),U,2)
+5 SET DA=$PIECE(AMHN(AMHY),U,2)
SET DR=".01///@"
DO ^DIE
KILL DIE,DR,DA,Y
WRITE !!
+6 DO PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
RNO1X ;xit
+1 KILL AMHPIEN,AMHL,AMHX,AMHN,AMHY
+2 QUIT
MN1 ;EP - called to modify a note
+1 IF $DATA(IOF)
WRITE @IOF
+2 KILL AMHN,AMHL,AMHX,AMHC
+3 WRITE !!,"Editing a Note on the following problem on ",$PIECE($PIECE(^DPT(DFN,0),U),",",2)," ",$PIECE($PIECE(^(0),U),","),"'s Problem List.",!
+4 SET (X,D)=0
FOR
SET X=$ORDER(^TMP($JOB,"AMHPL","IDX",X))
IF X'=+X!D
QUIT
SET Y=$ORDER(^TMP($JOB,"AMHPL","IDX",X,0))
IF Y>AMHPIEN
SET D=1
IF ^TMP($JOB,"AMHPL","IDX",X,Y)=AMHPIEN
WRITE !,^TMP($JOB,"AMHPL",X,0)
+5 SET AMHC=0
IF $ORDER(^AUPNPROB(AMHPIEN,11,0))
Begin DoDot:1
+6 WRITE !!?6,IORVON,"Problem Notes: ",IORVOFF
SET (AMHC,AMHL)=0
FOR
SET AMHL=$ORDER(^AUPNPROB(AMHPIEN,11,AMHL))
IF AMHL'=+AMHL
QUIT
IF $ORDER(^AUPNPROB(AMHPIEN,11,AMHL,11,0))
WRITE !?6,$PIECE(^DIC(4,$PIECE(^AUPNPROB(AMHPIEN,11,AMHL,0),U),0),U)
Begin DoDot:2
+7 SET AMHX=0
FOR
SET AMHX=$ORDER(^AUPNPROB(AMHPIEN,11,AMHL,11,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:3
+8 SET AMHC=AMHC+1
SET AMHN(AMHC)=AMHL_U_AMHX
WRITE !?8,AMHC,") Note#",$PIECE(^AUPNPROB(AMHPIEN,11,AMHL,11,AMHX,0),U)," ",$$FMTE^XLFDT($PIECE(^(0),U,5),5),?30,$PIECE(^AUPNPROB(AMHPIEN,11,AMHL,11,AMHX,0),U,3)
End DoDot:3
End DoDot:2
End DoDot:1
+9 IF AMHC=0
WRITE !?8,"No notes on file for this problem"
GOTO RNO1X
+10 WRITE !
KILL DIR
SET DIR(0)="N^1:"_AMHC_":"
SET DIR("A")="Edit which one"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+11 IF $DATA(DIRUT)
WRITE !,"Okay, bye."
GOTO RNO1X
+12 IF 'Y
WRITE !,"No Note selected"
GOTO RNO1X
+13 SET AMHY=+Y
MSURE ;
+1 SET DA(1)=$PIECE(AMHN(AMHY),U)
SET DA(2)=AMHPIEN
SET DIE="^AUPNPROB("_AMHPIEN_",11,"_$PIECE(AMHN(AMHY),U)_",11,"
SET DIC("P")=$PIECE(^DD(9000011.11,1101,0),U,2)
+2 SET DA=$PIECE(AMHN(AMHY),U,2)
SET DR=".01;.03"
DO ^DIE
KILL DIE,DR,DA,Y
WRITE !!
+3 DO PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
MNO1X ;
+1 KILL AMHPIEN,AMHL,AMHX,AMHN,AMHY
+2 QUIT
