APCHTPU ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 15-NOV-2000 ;
;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
;; ;
EP ;EP - called from option to select and display a TP
W:$D(IOF) @IOF
W !!,"This option will allow a site to specify sex, age ranges and frequencies for",!,"a health maintenance reminder.",!!
D ^XBFMK
S DIC="^APCHSURV(",DIC("A")="Select BEST PRACTICE PROMPT to Modify: ",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,3)'=""D"",$P(^(0),U,7)=""T""" D ^DIC
I Y=-1 D EXIT Q
S APCHTP=+Y
EN ; -- main entry point for APCH MODIFY TP
D EN^VALM("APCH MODIFY TP")
D CLEAR^VALM1
D FULL^VALM1
D EXIT
Q
;
HDR ; -- header code
S VALMHDR(1)="Modify Best Practice Prompt Criteria"
Q
;
INIT ; -- init variables and list array
K ^TMP("APCHTPU",$J)
S ^TMP("APCHTPU",$J,0)=0
;gather up reminder for display
S C=0,X="",X="Best Practice Prompt:",$E(X,20)=$P(^APCHSURV(APCHTP,0),U) D S(X)
S X="",X="Status:",$E(X,20)=$$VAL^XBDIQ1(9001018,APCHTP,.03) D S(X)
S X="Description:" D S(X,1)
S Y=0 F S Y=$O(^APCHSURV(APCHTP,1,Y)) Q:Y'=+Y S X="",$E(X,2)=^APCHSURV(APCHTP,1,Y,0) D S(X)
S X="Best Practice Prompt Text: " D S(X,1)
S Y=0 F S Y=$O(^APCHSURV(APCHTP,12,Y)) Q:Y'=+Y S X="",$E(X,2)=^APCHSURV(APCHTP,12,Y,0) D S(X)
S X="Currently Defined Criteria in Use at this Facility" D S(X,1)
S Y=0 F S Y=$O(^APCHSURV(APCHTP,11,Y)) Q:Y'=+Y D
.S Z="",$E(Z,2)="Sex: "_$S($P(^APCHSURV(APCHTP,11,Y,0),U)="F":"FEMALE",$P(^APCHSURV(APCHTP,11,Y,0),U)="M":"MALE",$P(^APCHSURV(APCHTP,11,Y,0),U)="B":"ALL GENDERS",$P(^APCHSURV(APCHTP,11,Y,0),U)="U":"UNKNOWN",1:"")
.S J=0 F S J=$O(^APCHSURV(APCHTP,11,Y,11,J)) Q:J'=+J D
..S X=Z,$E(X,21)="Mininum Age: "_$P(^APCHSURV(APCHTP,11,Y,11,J,0),U),$E(X,40)="Maximum Age: "_$P(^APCHSURV(APCHTP,11,Y,11,J,0),U,2),$E(X,60)="Frequency: "_$P(^APCHSURV(APCHTP,11,Y,11,J,0),U,3) D S(X)
..Q
.Q
S X="Currently defined on the following summary types:" D S(X,1)
S J=0 F S J=$O(^APCHSCTL(J)) Q:J'=+J D
.S K=0 F S K=$O(^APCHSCTL(J,5,K)) Q:K'=+K I $P(^APCHSCTL(J,5,K,0),U,2)=APCHTP S X="",$E(X,15)=$P(^APCHSCTL(J,0),U) D S(X)
S VALMCNT=^TMP("APCHTPU",$J,0)
K ^TMP("APCHTPU",$J,0)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
D EN^XBVK("APCH")
Q
;
EXPND ; -- expand code
Q
;
S(Y,F,C,T) ;set up array
I '$G(F) S F=0
I '$G(T) S T=0
;blank lines
F F=1:1:F S X="" D S1
S X=Y
I $G(C) S L=$L(Y),T=(80-L)/2 D D S1 Q
.F %=1:1:(T-1) S X=" "_X
F %=1:1:T S X=" "_Y
D S1
Q
S1 ;
S %=$P(^TMP("APCHTPU",$J,0),U)+1,$P(^TMP("APCHTPU",$J,0),U)=%
S ^TMP("APCHTPU",$J,%,0)=X
Q
;
BACK ;go back to listman
D TERM^VALM0
S VALMBCK="R"
D INIT
D HDR
K DIR
K X,Y,Z,I
Q
;
MOD ;EP - called from protocol
I '$G(APCHTP) W !,"Protocol entry not defined." H 3 D BACK Q
D FULL^VALM1
D HM
D BACK
Q
HM ;EP - update methods
W:$D(IOF) @IOF
W !,"You may add a new sex, age range, frequency combination or edit and existing",!,"one for the ",$P(^APCHSURV(APCHTP,0),U)," reminder.",!
D DISPHM
I APCHC=0 W !,"No local criteria currently defined.",! S DIR(0)="Y",DIR("A")="Do you wish to ADD some",DIR("B")="Y" D ^DIR K DIR S:$D(DUOUT) DIRUT=1 Q:$D(DIRUT) Q:'Y D AHM G HM
;add or edit one of above
W ! S DIR(0)="S^A:ADD a new one;D:DELETE one of the above;Q:QUIT",DIR("A")="Do you wish to" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) W !!,"Bye." Q
I Y="Q" W !!,"Bye." Q
D @(Y_"HM")
G HM
DISPHM ;
S APCHC=0 K APCHSEL
Q:'$D(^APCHSURV(APCHTP,11))
S (APCHQUIT,APCHC)=0 K APCHSEL
S APCHGIEN=0
F S APCHGIEN=$O(^APCHSURV(APCHTP,11,APCHGIEN)) Q:APCHGIEN'=+APCHGIEN!(APCHQUIT) S APCHSEX=$P(^APCHSURV(APCHTP,11,APCHGIEN,0),U),APCHSEXR=$S(APCHSEX="F":"FEMALE",APCHSEX="M":"MALE",APCHSEX="B":"ALL GENDERS",APCHSEX="U":"UNKNOWN",1:"") D
.S APCHA=0 F S APCHA=$O(^APCHSURV(APCHTP,11,APCHGIEN,11,APCHA)) Q:APCHA'=+APCHA!(APCHQUIT) D
..S APCHC=APCHC+1,APCHSEL(APCHC)=APCHTP_U_APCHGIEN_U_APCHA W !?5,APCHC,") ",?9,APCHSEXR,?22,$$WAGE(APCHTP,APCHGIEN,APCHA),?50,$$WF(APCHTP,APCHGIEN,APCHA)
.Q ;quit when necessary
Q
AHM ;add a new pov
S APCH1=""
S DIR(0)="S^F:FEMALE;M:MALE;U:UNKNOWN;B:ALL GENDERS",DIR("A")="Enter GENDER" KILL DA D ^DIR KILL DIR
Q:$D(DIRUT)
S APCH1=Y
MIN ;min age apch2
W !!,"Now enter the minimum age in the age range. It must be entered in the following",!,"format: 1Y, 2M, 30D, 10Y, where Y=years, M=months, D=days"
S APCH2=""
S DIR(0)="F^2:10",DIR("A")="Enter MINIMUM Age" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G AHM
D INP^APCHSMU G:'$D(X) MIN
S APCH2=Y
MAX ;
W !!,"Now enter the maximum age in the age range. It must be entered in the following",!,"format: 1Y, 2M, 30D, 10Y, where Y=years, M=months, D=days"
S APCH3=""
S DIR(0)="FO^2:10",DIR("A")="Enter MAXIMUM Age" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G AHM
I X]"" D INP^APCHSMU G:'$D(X) MAX
S APCH3=Y
FREQ ;
W !!,"Now enter the frequency for ",$S(APCH1="F":"FEMALES",APCH1="M":"MALES",APCH1="B":"BOTH GENDERS"),", ages ",$$W(APCH2)," to ",$$W(APCH3),!,"It must be in the form: 2Y for every 2 years, 3M for every 3 months, etc.",!
S APCH4=""
S DIR(0)="F^2:10",DIR("A")="Enter FREQUENCY" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G AHM
D INP^APCHSMU G:'$D(X) FREQ
S APCH4=Y
W !!,"The following will be added:",!,?5,$S(APCH1="F":"FEMALES",APCH1="M":"MALES",APCH1="B":"ALL GENDERS",APCH1="U":"UNKNOWN"),", ages ",$$W(APCH2)," to ",$$W(APCH3)," reminder due every ",$$W(APCH4)
CONTA ;
S DIR(0)="Y",DIR("A")="Everything okay? Do you wish to continue and add it",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) K APCH1,APCH2,APCH3,APCH4 Q
I 'Y K APCH1,APCH2,APCH3,APCH4 Q
;add to multiple
S (X,N,G,C)=0 F S X=$O(^APCHSURV(APCHTP,11,X)) Q:X'=+X S:$P(^APCHSURV(APCHTP,11,X,0),U)=APCH1 G=X S N=X,C=C+1
I 'G S N=N+1,G=N
;G is first level subscript , C is total number of entries
S ^APCHSURV(APCHTP,11,0)="^9001018.11S^"_G_"^"_C
S ^APCHSURV(APCHTP,11,G,0)=APCH1
S (N,X)=0 F S X=$O(^APCHSURV(APCHTP,11,G,11,X)) Q:X'=+X S N=X
S N=N+1 ;N is second level subscript
S ^APCHSURV(APCHTP,11,G,11,0)="^9001018.1111^"_N_"^"_N
S ^APCHSURV(APCHTP,11,G,11,N,0)=APCH2_U_APCH3_U_APCH4
S DA=APCHTP,DIK="^APCHSURV(" D IX^DIK
Q
Q
DHM ;delete pov
W:$D(IOF) @IOF
D DISPHM
S DIR(0)="N^1:"_APCHC_":",DIR("A")="Which one do you wish to DELETE" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) Q
Q:'Y
S APCHC=Y
I '$D(APCHSEL(APCHC)) W !!,"Invalid choice." Q
;
S DIR(0)="Y",DIR("A")="Are you sure you want to delete this age range/frequency",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
I 'Y W !,"Okay, not deleted." Q
S DA(2)=$P(APCHSEL(APCHC),U),DA(1)=$P(APCHSEL(APCHC),U,2),DA=$P(APCHSEL(APCHC),U,3),DIK="^APCHSURV("_DA(2)_",11,"_DA(1)_",11," D ^DIK
D BACK
Q
;
WAGE(H,G,A) ;
NEW X,Y,Z,B,E
S X=$P(^APCHSURV(H,11,G,11,A,0),U,1)
S Y=$P(^APCHSURV(H,11,G,11,A,0),U,2)
I X["Y" S B=+X_$S(+X=1:" year",1:" years")
I X["D" S B=+X_$S(+X=1:" day",1:" days")
I X["M" S B=+X_$S(+X=1:" month",1:" months")
I Y["Y" S E=+Y_$S(+Y=1:" year",1:" years")
I Y["D" S E=+Y_$S(+Y=1:" day",1:" days")
I Y["M" S E=+Y_$S(+Y=1:" month",1:" months")
Q B_"-"_E
WF(H,G,A) ;
NEW X,Y,Z,B,E
S X=$P(^APCHSURV(H,11,G,11,A,0),U,3)
I X["Y" S B=+X_$S(+X=1:" year",1:" years")
I X["D" S B=+X_$S(+X=1:" day",1:" days")
I X["M" S B=+X_$S(+X=1:" month",1:" months")
Q B
;
W(A) ;
NEW B
I A["Y" S B=+A_$S(+A=1:" year",1:" years")
I A["D" S B=+A_$S(+A=1:" day",1:" days")
I A["M" S B=+A_$S(+A=1:" month",1:" months")
Q B
APCHTPU ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 15-NOV-2000 ;
+1 ;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
+2 ;; ;
EP ;EP - called from option to select and display a TP
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !!,"This option will allow a site to specify sex, age ranges and frequencies for",!,"a health maintenance reminder.",!!
+3 DO ^XBFMK
+4 SET DIC="^APCHSURV("
SET DIC("A")="Select BEST PRACTICE PROMPT to Modify: "
SET DIC(0)="AEMQ"
SET DIC("S")="I $P(^(0),U,3)'=""D"",$P(^(0),U,7)=""T"""
DO ^DIC
+5 IF Y=-1
DO EXIT
QUIT
+6 SET APCHTP=+Y
EN ; -- main entry point for APCH MODIFY TP
+1 DO EN^VALM("APCH MODIFY TP")
+2 DO CLEAR^VALM1
+3 DO FULL^VALM1
+4 DO EXIT
+5 QUIT
+6 ;
HDR ; -- header code
+1 SET VALMHDR(1)="Modify Best Practice Prompt Criteria"
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 KILL ^TMP("APCHTPU",$JOB)
+2 SET ^TMP("APCHTPU",$JOB,0)=0
+3 ;gather up reminder for display
+4 SET C=0
SET X=""
SET X="Best Practice Prompt:"
SET $EXTRACT(X,20)=$PIECE(^APCHSURV(APCHTP,0),U)
DO S(X)
+5 SET X=""
SET X="Status:"
SET $EXTRACT(X,20)=$$VAL^XBDIQ1(9001018,APCHTP,.03)
DO S(X)
+6 SET X="Description:"
DO S(X,1)
+7 SET Y=0
FOR
SET Y=$ORDER(^APCHSURV(APCHTP,1,Y))
IF Y'=+Y
QUIT
SET X=""
SET $EXTRACT(X,2)=^APCHSURV(APCHTP,1,Y,0)
DO S(X)
+8 SET X="Best Practice Prompt Text: "
DO S(X,1)
+9 SET Y=0
FOR
SET Y=$ORDER(^APCHSURV(APCHTP,12,Y))
IF Y'=+Y
QUIT
SET X=""
SET $EXTRACT(X,2)=^APCHSURV(APCHTP,12,Y,0)
DO S(X)
+10 SET X="Currently Defined Criteria in Use at this Facility"
DO S(X,1)
+11 SET Y=0
FOR
SET Y=$ORDER(^APCHSURV(APCHTP,11,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+12 SET Z=""
SET $EXTRACT(Z,2)="Sex: "_$SELECT($PIECE(^APCHSURV(APCHTP,11,Y,0),U)="F":"FEMALE",$PIECE(^APCHSURV(APCHTP,11,Y,0),U)="M":"MALE",$PIECE(^APCHSURV(APCHTP,11,Y,0),U)="B":"ALL GENDERS",$PIECE(^APCHSURV(APCHTP,11,Y,0),U)="U":"UNKNOWN",1:"")
+13 SET J=0
FOR
SET J=$ORDER(^APCHSURV(APCHTP,11,Y,11,J))
IF J'=+J
QUIT
Begin DoDot:2
+14 SET X=Z
SET $EXTRACT(X,21)="Mininum Age: "_$PIECE(^APCHSURV(APCHTP,11,Y,11,J,0),U)
SET $EXTRACT(X,40)="Maximum Age: "_$PIECE(^APCHSURV(APCHTP,11,Y,11,J,0),U,2)
SET $EXTRACT(X,60)="Frequency: "_$PIECE(^APCHSURV(APCHTP,11,Y,11,J,0),U,3)
DO S(X)
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 SET X="Currently defined on the following summary types:"
DO S(X,1)
+18 SET J=0
FOR
SET J=$ORDER(^APCHSCTL(J))
IF J'=+J
QUIT
Begin DoDot:1
+19 SET K=0
FOR
SET K=$ORDER(^APCHSCTL(J,5,K))
IF K'=+K
QUIT
IF $PIECE(^APCHSCTL(J,5,K,0),U,2)=APCHTP
SET X=""
SET $EXTRACT(X,15)=$PIECE(^APCHSCTL(J,0),U)
DO S(X)
End DoDot:1
+20 SET VALMCNT=^TMP("APCHTPU",$JOB,0)
+21 KILL ^TMP("APCHTPU",$JOB,0)
+22 QUIT
+23 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 DO EN^XBVK("APCH")
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
S(Y,F,C,T) ;set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 ;blank lines
+4 FOR F=1:1:F
SET X=""
DO S1
+5 SET X=Y
+6 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+7 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+8 FOR %=1:1:T
SET X=" "_Y
+9 DO S1
+10 QUIT
S1 ;
+1 SET %=$PIECE(^TMP("APCHTPU",$JOB,0),U)+1
SET $PIECE(^TMP("APCHTPU",$JOB,0),U)=%
+2 SET ^TMP("APCHTPU",$JOB,%,0)=X
+3 QUIT
+4 ;
BACK ;go back to listman
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO INIT
+4 DO HDR
+5 KILL DIR
+6 KILL X,Y,Z,I
+7 QUIT
+8 ;
MOD ;EP - called from protocol
+1 IF '$GET(APCHTP)
WRITE !,"Protocol entry not defined."
HANG 3
DO BACK
QUIT
+2 DO FULL^VALM1
+3 DO HM
+4 DO BACK
+5 QUIT
HM ;EP - update methods
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,"You may add a new sex, age range, frequency combination or edit and existing",!,"one for the ",$PIECE(^APCHSURV(APCHTP,0),U)," reminder.",!
+3 DO DISPHM
+4 IF APCHC=0
WRITE !,"No local criteria currently defined.",!
SET DIR(0)="Y"
SET DIR("A")="Do you wish to ADD some"
SET DIR("B")="Y"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
IF $DATA(DIRUT)
QUIT
IF 'Y
QUIT
DO AHM
GOTO HM
+5 ;add or edit one of above
+6 WRITE !
SET DIR(0)="S^A:ADD a new one;D:DELETE one of the above;Q:QUIT"
SET DIR("A")="Do you wish to"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+7 IF $DATA(DIRUT)
WRITE !!,"Bye."
QUIT
+8 IF Y="Q"
WRITE !!,"Bye."
QUIT
+9 DO @(Y_"HM")
+10 GOTO HM
DISPHM ;
+1 SET APCHC=0
KILL APCHSEL
+2 IF '$DATA(^APCHSURV(APCHTP,11))
QUIT
+3 SET (APCHQUIT,APCHC)=0
KILL APCHSEL
+4 SET APCHGIEN=0
+5 FOR
SET APCHGIEN=$ORDER(^APCHSURV(APCHTP,11,APCHGIEN))
IF APCHGIEN'=+APCHGIEN!(APCHQUIT)
QUIT
SET APCHSEX=$PIECE(^APCHSURV(APCHTP,11,APCHGIEN,0),U)
SET APCHSEXR=$SELECT(APCHSEX="F":"FEMALE",APCHSEX="M":"MALE",APCHSEX="B":"ALL GENDERS",APCHSEX="U":"UNKNOWN",1:"")
Begin DoDot:1
+6 SET APCHA=0
FOR
SET APCHA=$ORDER(^APCHSURV(APCHTP,11,APCHGIEN,11,APCHA))
IF APCHA'=+APCHA!(APCHQUIT)
QUIT
Begin DoDot:2
+7 SET APCHC=APCHC+1
SET APCHSEL(APCHC)=APCHTP_U_APCHGIEN_U_APCHA
WRITE !?5,APCHC,") ",?9,APCHSEXR,?22,$$WAGE(APCHTP,APCHGIEN,APCHA),?50,$$WF(APCHTP,APCHGIEN,APCHA)
End DoDot:2
+8 ;quit when necessary
QUIT
End DoDot:1
+9 QUIT
AHM ;add a new pov
+1 SET APCH1=""
+2 SET DIR(0)="S^F:FEMALE;M:MALE;U:UNKNOWN;B:ALL GENDERS"
SET DIR("A")="Enter GENDER"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
QUIT
+4 SET APCH1=Y
MIN ;min age apch2
+1 WRITE !!,"Now enter the minimum age in the age range. It must be entered in the following",!,"format: 1Y, 2M, 30D, 10Y, where Y=years, M=months, D=days"
+2 SET APCH2=""
+3 SET DIR(0)="F^2:10"
SET DIR("A")="Enter MINIMUM Age"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO AHM
+5 DO INP^APCHSMU
IF '$DATA(X)
GOTO MIN
+6 SET APCH2=Y
MAX ;
+1 WRITE !!,"Now enter the maximum age in the age range. It must be entered in the following",!,"format: 1Y, 2M, 30D, 10Y, where Y=years, M=months, D=days"
+2 SET APCH3=""
+3 SET DIR(0)="FO^2:10"
SET DIR("A")="Enter MAXIMUM Age"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO AHM
+5 IF X]""
DO INP^APCHSMU
IF '$DATA(X)
GOTO MAX
+6 SET APCH3=Y
FREQ ;
+1 WRITE !!,"Now enter the frequency for ",$SELECT(APCH1="F":"FEMALES",APCH1="M":"MALES",APCH1="B":"BOTH GENDERS"),", ages ",$$W(APCH2)," to ",$$W(APCH3),!,"It must be in the form: 2Y for every 2 years, 3M for every 3 months, etc.",!
+2 SET APCH4=""
+3 SET DIR(0)="F^2:10"
SET DIR("A")="Enter FREQUENCY"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO AHM
+5 DO INP^APCHSMU
IF '$DATA(X)
GOTO FREQ
+6 SET APCH4=Y
+7 WRITE !!,"The following will be added:",!,?5,$SELECT(APCH1="F":"FEMALES",APCH1="M":"MALES",APCH1="B":"ALL GENDERS",APCH1="U":"UNKNOWN"),", ages ",$$W(APCH2)," to ",$$W(APCH3)," reminder due every ",$$W(APCH4)
CONTA ;
+1 SET DIR(0)="Y"
SET DIR("A")="Everything okay? Do you wish to continue and add it"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
KILL APCH1,APCH2,APCH3,APCH4
QUIT
+3 IF 'Y
KILL APCH1,APCH2,APCH3,APCH4
QUIT
+4 ;add to multiple
+5 SET (X,N,G,C)=0
FOR
SET X=$ORDER(^APCHSURV(APCHTP,11,X))
IF X'=+X
QUIT
IF $PIECE(^APCHSURV(APCHTP,11,X,0),U)=APCH1
SET G=X
SET N=X
SET C=C+1
+6 IF 'G
SET N=N+1
SET G=N
+7 ;G is first level subscript , C is total number of entries
+8 SET ^APCHSURV(APCHTP,11,0)="^9001018.11S^"_G_"^"_C
+9 SET ^APCHSURV(APCHTP,11,G,0)=APCH1
+10 SET (N,X)=0
FOR
SET X=$ORDER(^APCHSURV(APCHTP,11,G,11,X))
IF X'=+X
QUIT
SET N=X
+11 ;N is second level subscript
SET N=N+1
+12 SET ^APCHSURV(APCHTP,11,G,11,0)="^9001018.1111^"_N_"^"_N
+13 SET ^APCHSURV(APCHTP,11,G,11,N,0)=APCH2_U_APCH3_U_APCH4
+14 SET DA=APCHTP
SET DIK="^APCHSURV("
DO IX^DIK
+15 QUIT
+16 QUIT
DHM ;delete pov
+1 IF $DATA(IOF)
WRITE @IOF
+2 DO DISPHM
+3 SET DIR(0)="N^1:"_APCHC_":"
SET DIR("A")="Which one do you wish to DELETE"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF $DATA(DIRUT)
QUIT
+5 IF 'Y
QUIT
+6 SET APCHC=Y
+7 IF '$DATA(APCHSEL(APCHC))
WRITE !!,"Invalid choice."
QUIT
+8 ;
+9 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this age range/frequency"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+10 IF $DATA(DIRUT)
QUIT
+11 IF 'Y
WRITE !,"Okay, not deleted."
QUIT
+12 SET DA(2)=$PIECE(APCHSEL(APCHC),U)
SET DA(1)=$PIECE(APCHSEL(APCHC),U,2)
SET DA=$PIECE(APCHSEL(APCHC),U,3)
SET DIK="^APCHSURV("_DA(2)_",11,"_DA(1)_",11,"
DO ^DIK
+13 DO BACK
+14 QUIT
+15 ;
WAGE(H,G,A) ;
+1 NEW X,Y,Z,B,E
+2 SET X=$PIECE(^APCHSURV(H,11,G,11,A,0),U,1)
+3 SET Y=$PIECE(^APCHSURV(H,11,G,11,A,0),U,2)
+4 IF X["Y"
SET B=+X_$SELECT(+X=1:" year",1:" years")
+5 IF X["D"
SET B=+X_$SELECT(+X=1:" day",1:" days")
+6 IF X["M"
SET B=+X_$SELECT(+X=1:" month",1:" months")
+7 IF Y["Y"
SET E=+Y_$SELECT(+Y=1:" year",1:" years")
+8 IF Y["D"
SET E=+Y_$SELECT(+Y=1:" day",1:" days")
+9 IF Y["M"
SET E=+Y_$SELECT(+Y=1:" month",1:" months")
+10 QUIT B_"-"_E
WF(H,G,A) ;
+1 NEW X,Y,Z,B,E
+2 SET X=$PIECE(^APCHSURV(H,11,G,11,A,0),U,3)
+3 IF X["Y"
SET B=+X_$SELECT(+X=1:" year",1:" years")
+4 IF X["D"
SET B=+X_$SELECT(+X=1:" day",1:" days")
+5 IF X["M"
SET B=+X_$SELECT(+X=1:" month",1:" months")
+6 QUIT B
+7 ;
W(A) ;
+1 NEW B
+2 IF A["Y"
SET B=+A_$SELECT(+A=1:" year",1:" years")
+3 IF A["D"
SET B=+A_$SELECT(+A=1:" day",1:" days")
+4 IF A["M"
SET B=+A_$SELECT(+A=1:" month",1:" months")
+5 QUIT B
