Routine: AMHPL2

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

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

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

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

AMHPL2.m