APCDPL2 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
;;2.0;IHS PCC SUITE;**5**;MAY 14, 2009
;
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,"APCDPL","IDX",X)) Q:X'=+X!D S Y=$O(^TMP($J,"APCDPL","IDX",X,0)) S:Y>APCDPIEN D=1 I ^TMP($J,"APCDPL","IDX",X,Y)=APCDPIEN W !,^TMP($J,"APCDPL",X,0)
I $O(^AUPNPROB(APCDPIEN,11,0)) D
.W !!?6,IORVON,"Problem Notes: ",IORVOFF S L=0 F S L=$O(^AUPNPROB(APCDPIEN,11,L)) Q:L'=+L I $O(^AUPNPROB(APCDPIEN,11,L,11,0)) W !?6,$P(^DIC(4,$P(^AUPNPROB(APCDPIEN,11,L,0),U),0),U) D
..S X=0 F S X=$O(^AUPNPROB(APCDPIEN,11,L,11,X)) Q:X'=+X W !?8,"Note#",$P(^AUPNPROB(APCDPIEN,11,L,11,X,0),U)," ",$$FMTE^XLFDT($P(^(0),U,5),5),?30,$P(^AUPNPROB(APCDPIEN,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 APCDNIEN=$O(^AUPNPROB(APCDPIEN,11,"B",$S($G(APCDLOC):APCDLOC,1:DUZ(2)),0))
I APCDNIEN="" S DIADD=9000011.11,X="`"_$S($G(APCDLOC):APCDLOC,1:DUZ(2)),DIC="^AUPNPROB("_APCDPIEN_",11,",DA(1)=APCDPIEN,DIC(0)="L",DIC("P")=$P(^DD(9000011,1101,0),U,2) D
.D ^DIC K DIC,DA,DR,Y,DIADD,X S APCDNIEN=$O(^AUPNPROB(APCDPIEN,11,"B",$S($G(APCDLOC):APCDLOC,1:DUZ(2)),0))
I APCDNIEN="" W $C(7),$C(7),"ERROR UPDATING NOTE LOCATION MULTIPLE" G NOX
S (Y,X)=0 F S Y=$O(^AUPNPROB(APCDPIEN,11,APCDNIEN,11,"B",Y)) S:Y X=Y I 'Y S X=X+1 K Y Q
S APCDNUM=X
W !!,"Adding Note #",X
K DIC S X=APCDNUM,DA(1)=APCDNIEN,DA(2)=APCDPIEN,DIC="^AUPNPROB("_APCDPIEN_",11,"_APCDNIEN_",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(APCDDATE)]"":$P(APCDDATE,"."),1:DT) D ^DIE K DIE,DR,DA,Y W !!
S APCDPAT=APCDPLPT
;S:'$G(APCDLOC) APCDLOC=DUZ(2)
S:$G(APCDDATE)="" APCDDATE=APCDNDT ; set up vars needed by pcc data entry template
S APCDVSIT=$G(APCDPLV)
S DA=APCDPIEN
D PLUDE^APCDAPRB
D ^XBFMK
K DIADD
G NO1
NOX ;
K Y,APCDPIEN,X,L,APCDNUM,APCDL,DIC,DA,DD,APCDC,APCDN,APCDNIEN,DR,DIADD
Q
RNO1 ;EP - called from APCDPL1 - remove a note
W:$D(IOF) @IOF
K APCDN,APCDL,APCDX,APCDC
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,"APCDPL","IDX",X)) Q:X'=+X!D S Y=$O(^TMP($J,"APCDPL","IDX",X,0)) S:Y>APCDPIEN D=1 I ^TMP($J,"APCDPL","IDX",X,Y)=APCDPIEN W !,^TMP($J,"APCDPL",X,0)
S APCDC=0 I $O(^AUPNPROB(APCDPIEN,11,0)) D
.W !!?6,IORVON,"Problem Notes: ",IORVOFF S (APCDC,APCDL)=0 F S APCDL=$O(^AUPNPROB(APCDPIEN,11,APCDL)) Q:APCDL'=+APCDL I $O(^AUPNPROB(APCDPIEN,11,APCDL,11,0)) W !?6,$P(^DIC(4,$P(^AUPNPROB(APCDPIEN,11,APCDL,0),U),0),U) D
..S APCDX=0 F S APCDX=$O(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX)) Q:APCDX'=+APCDX D
...S APCDC=APCDC+1,APCDN(APCDC)=APCDL_U_APCDX W !?8,APCDC,") Note#",$P(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX,0),U)," ",$$FMTE^XLFDT($P(^(0),U,5),5),?30,$P(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX,0),U,3)
I APCDC=0 W !?8,"No note on file for this problem" G RNO1X
W ! K DIR S DIR(0)="N^1:"_APCDC_":",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 APCDY=+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(APCDN(APCDY),U),DA(2)=APCDPIEN,DIE="^AUPNPROB("_APCDPIEN_",11,"_$P(APCDN(APCDY),U)_",11,",DIC("P")=$P(^DD(9000011.11,1101,0),U,2)
S DA=$P(APCDN(APCDY),U,2),DR=".01///@" D ^DIE K DIE,DR,DA,Y W !!
S APCDPAT=APCDPLPT
;S:'$G(APCDLOC) APCDLOC=DUZ(2)
S:$G(APCDDATE)="" APCDDATE=APCDNDT ; set up vars needed by pcc data entry template
S APCDVSIT=$G(APCDPLV)
S DA=APCDPIEN
D PLUDE^APCDAPRB
RNO1X ;xit
K APCDPIEN,APCDL,APCDX,APCDN,APCDY
Q
MN1 ;EP - called to modify a note
W:$D(IOF) @IOF
K APCDN,APCDL,APCDX,APCDC
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,"APCDPL","IDX",X)) Q:X'=+X!D S Y=$O(^TMP($J,"APCDPL","IDX",X,0)) S:Y>APCDPIEN D=1 I ^TMP($J,"APCDPL","IDX",X,Y)=APCDPIEN W !,^TMP($J,"APCDPL",X,0)
S APCDC=0 I $O(^AUPNPROB(APCDPIEN,11,0)) D
.W !!?6,IORVON,"Problem Notes: ",IORVOFF S (APCDC,APCDL)=0 F S APCDL=$O(^AUPNPROB(APCDPIEN,11,APCDL)) Q:APCDL'=+APCDL I $O(^AUPNPROB(APCDPIEN,11,APCDL,11,0)) W !?6,$P(^DIC(4,$P(^AUPNPROB(APCDPIEN,11,APCDL,0),U),0),U) D
..S APCDX=0 F S APCDX=$O(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX)) Q:APCDX'=+APCDX D
...S APCDC=APCDC+1,APCDN(APCDC)=APCDL_U_APCDX W !?8,APCDC,") Note#",$P(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX,0),U)," ",$$FMTE^XLFDT($P(^(0),U,5),5),?30,$P(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX,0),U,3)
I APCDC=0 W !?8,"No notes on file for this problem" G RNO1X
W ! K DIR S DIR(0)="N^1:"_APCDC_":",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 APCDY=+Y
MSURE ;
S DA(1)=$P(APCDN(APCDY),U),DA(2)=APCDPIEN,DIE="^AUPNPROB("_APCDPIEN_",11,"_$P(APCDN(APCDY),U)_",11,",DIC("P")=$P(^DD(9000011.11,1101,0),U,2)
S DA=$P(APCDN(APCDY),U,2),DR=".01;.03" D ^DIE K DIE,DR,DA,Y W !!
S APCDPAT=APCDPLPT
;S:'$G(APCDLOC) APCDLOC=DUZ(2)
S:$G(APCDDATE)="" APCDDATE=APCDNDT ; set up vars needed by pcc data entry template
S APCDVSIT=$G(APCDPLV)
S DA=APCDPIEN
D PLUDE^APCDAPRB
MNO1X ;
K APCDPIEN,APCDL,APCDX,APCDN,APCDY
Q
APCDPL2 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
+1 ;;2.0;IHS PCC SUITE;**5**;MAY 14, 2009
+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,"APCDPL","IDX",X))
IF X'=+X!D
QUIT
SET Y=$ORDER(^TMP($JOB,"APCDPL","IDX",X,0))
IF Y>APCDPIEN
SET D=1
IF ^TMP($JOB,"APCDPL","IDX",X,Y)=APCDPIEN
WRITE !,^TMP($JOB,"APCDPL",X,0)
+4 IF $ORDER(^AUPNPROB(APCDPIEN,11,0))
Begin DoDot:1
+5 WRITE !!?6,IORVON,"Problem Notes: ",IORVOFF
SET L=0
FOR
SET L=$ORDER(^AUPNPROB(APCDPIEN,11,L))
IF L'=+L
QUIT
IF $ORDER(^AUPNPROB(APCDPIEN,11,L,11,0))
WRITE !?6,$PIECE(^DIC(4,$PIECE(^AUPNPROB(APCDPIEN,11,L,0),U),0),U)
Begin DoDot:2
+6 SET X=0
FOR
SET X=$ORDER(^AUPNPROB(APCDPIEN,11,L,11,X))
IF X'=+X
QUIT
WRITE !?8,"Note#",$PIECE(^AUPNPROB(APCDPIEN,11,L,11,X,0),U)," ",$$FMTE^XLFDT($PIECE(^(0),U,5),5),?30,$PIECE(^AUPNPROB(APCDPIEN,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 APCDNIEN=$ORDER(^AUPNPROB(APCDPIEN,11,"B",$SELECT($GET(APCDLOC):APCDLOC,1:DUZ(2)),0))
+3 IF APCDNIEN=""
SET DIADD=9000011.11
SET X="`"_$SELECT($GET(APCDLOC):APCDLOC,1:DUZ(2))
SET DIC="^AUPNPROB("_APCDPIEN_",11,"
SET DA(1)=APCDPIEN
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 APCDNIEN=$ORDER(^AUPNPROB(APCDPIEN,11,"B",$SELECT($GET(APCDLOC):APCDLOC,1:DUZ(2)),0))
End DoDot:1
+5 IF APCDNIEN=""
WRITE $CHAR(7),$CHAR(7),"ERROR UPDATING NOTE LOCATION MULTIPLE"
GOTO NOX
+6 SET (Y,X)=0
FOR
SET Y=$ORDER(^AUPNPROB(APCDPIEN,11,APCDNIEN,11,"B",Y))
IF Y
SET X=Y
IF 'Y
SET X=X+1
KILL Y
QUIT
+7 SET APCDNUM=X
+8 WRITE !!,"Adding Note #",X
+9 KILL DIC
SET X=APCDNUM
SET DA(1)=APCDNIEN
SET DA(2)=APCDPIEN
SET DIC="^AUPNPROB("_APCDPIEN_",11,"_APCDNIEN_",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(APCDDATE)]"":$PIECE(APCDDATE,"."),1:DT)
DO ^DIE
KILL DIE,DR,DA,Y
WRITE !!
+12 SET APCDPAT=APCDPLPT
+13 ;S:'$G(APCDLOC) APCDLOC=DUZ(2)
+14 ; set up vars needed by pcc data entry template
IF $GET(APCDDATE)=""
SET APCDDATE=APCDNDT
+15 SET APCDVSIT=$GET(APCDPLV)
+16 SET DA=APCDPIEN
+17 DO PLUDE^APCDAPRB
+18 DO ^XBFMK
+19 KILL DIADD
+20 GOTO NO1
NOX ;
+1 KILL Y,APCDPIEN,X,L,APCDNUM,APCDL,DIC,DA,DD,APCDC,APCDN,APCDNIEN,DR,DIADD
+2 QUIT
RNO1 ;EP - called from APCDPL1 - remove a note
+1 IF $DATA(IOF)
WRITE @IOF
+2 KILL APCDN,APCDL,APCDX,APCDC
+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,"APCDPL","IDX",X))
IF X'=+X!D
QUIT
SET Y=$ORDER(^TMP($JOB,"APCDPL","IDX",X,0))
IF Y>APCDPIEN
SET D=1
IF ^TMP($JOB,"APCDPL","IDX",X,Y)=APCDPIEN
WRITE !,^TMP($JOB,"APCDPL",X,0)
+5 SET APCDC=0
IF $ORDER(^AUPNPROB(APCDPIEN,11,0))
Begin DoDot:1
+6 WRITE !!?6,IORVON,"Problem Notes: ",IORVOFF
SET (APCDC,APCDL)=0
FOR
SET APCDL=$ORDER(^AUPNPROB(APCDPIEN,11,APCDL))
IF APCDL'=+APCDL
QUIT
IF $ORDER(^AUPNPROB(APCDPIEN,11,APCDL,11,0))
WRITE !?6,$PIECE(^DIC(4,$PIECE(^AUPNPROB(APCDPIEN,11,APCDL,0),U),0),U)
Begin DoDot:2
+7 SET APCDX=0
FOR
SET APCDX=$ORDER(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX))
IF APCDX'=+APCDX
QUIT
Begin DoDot:3
+8 SET APCDC=APCDC+1
SET APCDN(APCDC)=APCDL_U_APCDX
WRITE !?8,APCDC,") Note#",$PIECE(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX,0),U)," ",$$FMTE^XLFDT($PIECE(^(0),U,5),5),?30,$PIECE(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX,0),U,3)
End DoDot:3
End DoDot:2
End DoDot:1
+9 IF APCDC=0
WRITE !?8,"No note on file for this problem"
GOTO RNO1X
+10 WRITE !
KILL DIR
SET DIR(0)="N^1:"_APCDC_":"
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 APCDY=+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(APCDN(APCDY),U)
SET DA(2)=APCDPIEN
SET DIE="^AUPNPROB("_APCDPIEN_",11,"_$PIECE(APCDN(APCDY),U)_",11,"
SET DIC("P")=$PIECE(^DD(9000011.11,1101,0),U,2)
+5 SET DA=$PIECE(APCDN(APCDY),U,2)
SET DR=".01///@"
DO ^DIE
KILL DIE,DR,DA,Y
WRITE !!
+6 SET APCDPAT=APCDPLPT
+7 ;S:'$G(APCDLOC) APCDLOC=DUZ(2)
+8 ; set up vars needed by pcc data entry template
IF $GET(APCDDATE)=""
SET APCDDATE=APCDNDT
+9 SET APCDVSIT=$GET(APCDPLV)
+10 SET DA=APCDPIEN
+11 DO PLUDE^APCDAPRB
RNO1X ;xit
+1 KILL APCDPIEN,APCDL,APCDX,APCDN,APCDY
+2 QUIT
MN1 ;EP - called to modify a note
+1 IF $DATA(IOF)
WRITE @IOF
+2 KILL APCDN,APCDL,APCDX,APCDC
+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,"APCDPL","IDX",X))
IF X'=+X!D
QUIT
SET Y=$ORDER(^TMP($JOB,"APCDPL","IDX",X,0))
IF Y>APCDPIEN
SET D=1
IF ^TMP($JOB,"APCDPL","IDX",X,Y)=APCDPIEN
WRITE !,^TMP($JOB,"APCDPL",X,0)
+5 SET APCDC=0
IF $ORDER(^AUPNPROB(APCDPIEN,11,0))
Begin DoDot:1
+6 WRITE !!?6,IORVON,"Problem Notes: ",IORVOFF
SET (APCDC,APCDL)=0
FOR
SET APCDL=$ORDER(^AUPNPROB(APCDPIEN,11,APCDL))
IF APCDL'=+APCDL
QUIT
IF $ORDER(^AUPNPROB(APCDPIEN,11,APCDL,11,0))
WRITE !?6,$PIECE(^DIC(4,$PIECE(^AUPNPROB(APCDPIEN,11,APCDL,0),U),0),U)
Begin DoDot:2
+7 SET APCDX=0
FOR
SET APCDX=$ORDER(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX))
IF APCDX'=+APCDX
QUIT
Begin DoDot:3
+8 SET APCDC=APCDC+1
SET APCDN(APCDC)=APCDL_U_APCDX
WRITE !?8,APCDC,") Note#",$PIECE(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX,0),U)," ",$$FMTE^XLFDT($PIECE(^(0),U,5),5),?30,$PIECE(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX,0),U,3)
End DoDot:3
End DoDot:2
End DoDot:1
+9 IF APCDC=0
WRITE !?8,"No notes on file for this problem"
GOTO RNO1X
+10 WRITE !
KILL DIR
SET DIR(0)="N^1:"_APCDC_":"
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 APCDY=+Y
MSURE ;
+1 SET DA(1)=$PIECE(APCDN(APCDY),U)
SET DA(2)=APCDPIEN
SET DIE="^AUPNPROB("_APCDPIEN_",11,"_$PIECE(APCDN(APCDY),U)_",11,"
SET DIC("P")=$PIECE(^DD(9000011.11,1101,0),U,2)
+2 SET DA=$PIECE(APCDN(APCDY),U,2)
SET DR=".01;.03"
DO ^DIE
KILL DIE,DR,DA,Y
WRITE !!
+3 SET APCDPAT=APCDPLPT
+4 ;S:'$G(APCDLOC) APCDLOC=DUZ(2)
+5 ; set up vars needed by pcc data entry template
IF $GET(APCDDATE)=""
SET APCDDATE=APCDNDT
+6 SET APCDVSIT=$GET(APCDPLV)
+7 SET DA=APCDPIEN
+8 DO PLUDE^APCDAPRB
MNO1X ;
+1 KILL APCDPIEN,APCDL,APCDX,APCDN,APCDY
+2 QUIT
