Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCHTPU

APCHTPU.m

Go to the documentation of this file. 
  1. APCHTPU ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 15-NOV-2000 ;
  1.  ;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88
  1.  ;; ;
  1. EP ;EP - called from option to select and display a TP
  1.  W:$D(IOF) @IOF
  1.  W !!,"This option will allow a site to specify sex, age ranges and frequencies for",!,"a health maintenance reminder.",!!
  1.  D ^XBFMK
  1.  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
  1.  I Y=-1 D EXIT Q
  1.  S APCHTP=+Y
  1. EN ; -- main entry point for APCH MODIFY TP
  1.  D EN^VALM("APCH MODIFY TP")
  1.  D CLEAR^VALM1
  1.  D FULL^VALM1
  1.  D EXIT
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  S VALMHDR(1)="Modify Best Practice Prompt Criteria"
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  K ^TMP("APCHTPU",$J)
  1.  S ^TMP("APCHTPU",$J,0)=0
  1.  ;gather up reminder for display
  1.  S C=0,X="",X="Best Practice Prompt:",$E(X,20)=$P(^APCHSURV(APCHTP,0),U) D S(X)
  1.  S X="",X="Status:",$E(X,20)=$$VAL^XBDIQ1(9001018,APCHTP,.03) D S(X)
  1.  S X="Description:" D S(X,1)
  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)
  1.  S X="Best Practice Prompt Text: " D S(X,1)
  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)
  1.  S X="Currently Defined Criteria in Use at this Facility" D S(X,1)
  1.  S Y=0 F  S Y=$O(^APCHSURV(APCHTP,11,Y)) Q:Y'=+Y  D
  1.  .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:"")
  1.  .S J=0 F  S J=$O(^APCHSURV(APCHTP,11,Y,11,J)) Q:J'=+J  D
  1.  ..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)
  1.  ..Q
  1.  .Q
  1.  S X="Currently defined on the following summary types:" D S(X,1)
  1.  S J=0 F  S J=$O(^APCHSCTL(J)) Q:J'=+J  D
  1.  .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)
  1.  S VALMCNT=^TMP("APCHTPU",$J,0)
  1.  K ^TMP("APCHTPU",$J,0)
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  D EN^XBVK("APCH")
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. S(Y,F,C,T) ;set up array
  1.  I '$G(F) S F=0
  1.  I '$G(T) S T=0
  1.  ;blank lines
  1.  F F=1:1:F S X="" D S1
  1.  S X=Y
  1.  I $G(C) S L=$L(Y),T=(80-L)/2 D  D S1 Q
  1.  .F %=1:1:(T-1) S X=" "_X
  1.  F %=1:1:T S X=" "_Y
  1.  D S1
  1.  Q
  1. S1 ;
  1.  S %=$P(^TMP("APCHTPU",$J,0),U)+1,$P(^TMP("APCHTPU",$J,0),U)=%
  1.  S ^TMP("APCHTPU",$J,%,0)=X
  1.  Q
  1.  ;
  1. BACK ;go back to listman
  1.  D TERM^VALM0
  1.  S VALMBCK="R"
  1.  D INIT
  1.  D HDR
  1.  K DIR
  1.  K X,Y,Z,I
  1.  Q
  1.  ;
  1. MOD ;EP - called from protocol
  1.  I '$G(APCHTP) W !,"Protocol entry not defined." H 3 D BACK Q
  1.  D FULL^VALM1
  1.  D HM
  1.  D BACK
  1.  Q
  1. HM ;EP - update methods
  1.  W:$D(IOF) @IOF
  1.  W !,"You may add a new sex, age range, frequency combination or edit and existing",!,"one for the ",$P(^APCHSURV(APCHTP,0),U)," reminder.",!
  1.  D DISPHM
  1.  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
  1.  ;add or edit one of above
  1.  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
  1.  I $D(DIRUT) W !!,"Bye." Q
  1.  I Y="Q" W !!,"Bye." Q
  1.  D @(Y_"HM")
  1.  G HM
  1. DISPHM ;
  1.  S APCHC=0 K APCHSEL
  1.  Q:'$D(^APCHSURV(APCHTP,11))
  1.  S (APCHQUIT,APCHC)=0 K APCHSEL
  1.  S APCHGIEN=0
  1.  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
  1.  .S APCHA=0 F  S APCHA=$O(^APCHSURV(APCHTP,11,APCHGIEN,11,APCHA)) Q:APCHA'=+APCHA!(APCHQUIT)  D
  1.  ..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)
  1.  .Q  ;quit when necessary
  1.  Q
  1. AHM ;add a new pov
  1.  S APCH1=""
  1.  S DIR(0)="S^F:FEMALE;M:MALE;U:UNKNOWN;B:ALL GENDERS",DIR("A")="Enter GENDER" KILL DA D ^DIR KILL DIR
  1.  Q:$D(DIRUT)
  1.  S APCH1=Y
  1. MIN ;min age apch2
  1.  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"
  1.  S APCH2=""
  1.  S DIR(0)="F^2:10",DIR("A")="Enter MINIMUM Age" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G AHM
  1.  D INP^APCHSMU G:'$D(X) MIN
  1.  S APCH2=Y
  1. MAX ;
  1.  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"
  1.  S APCH3=""
  1.  S DIR(0)="FO^2:10",DIR("A")="Enter MAXIMUM Age" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G AHM
  1.  I X]"" D INP^APCHSMU G:'$D(X) MAX
  1.  S APCH3=Y
  1. FREQ ;
  1.  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.",!
  1.  S APCH4=""
  1.  S DIR(0)="F^2:10",DIR("A")="Enter FREQUENCY" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G AHM
  1.  D INP^APCHSMU G:'$D(X) FREQ
  1.  S APCH4=Y
  1.  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)
  1. CONTA ;
  1.  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
  1.  I $D(DIRUT) K APCH1,APCH2,APCH3,APCH4 Q
  1.  I 'Y K APCH1,APCH2,APCH3,APCH4 Q
  1.  ;add to multiple
  1.  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
  1.  I 'G S N=N+1,G=N
  1.  ;G is first level subscript , C is total number of entries
  1.  S ^APCHSURV(APCHTP,11,0)="^9001018.11S^"_G_"^"_C
  1.  S ^APCHSURV(APCHTP,11,G,0)=APCH1
  1.  S (N,X)=0 F  S X=$O(^APCHSURV(APCHTP,11,G,11,X)) Q:X'=+X  S N=X
  1.  S N=N+1  ;N is second level subscript
  1.  S ^APCHSURV(APCHTP,11,G,11,0)="^9001018.1111^"_N_"^"_N
  1.  S ^APCHSURV(APCHTP,11,G,11,N,0)=APCH2_U_APCH3_U_APCH4
  1.  S DA=APCHTP,DIK="^APCHSURV(" D IX^DIK
  1.  Q
  1.  Q
  1. DHM ;delete pov
  1.  W:$D(IOF) @IOF
  1.  D DISPHM
  1.  S DIR(0)="N^1:"_APCHC_":",DIR("A")="Which one do you wish to DELETE" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I $D(DIRUT) Q
  1.  Q:'Y
  1.  S APCHC=Y
  1.  I '$D(APCHSEL(APCHC)) W !!,"Invalid choice." Q
  1.  ;
  1.  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
  1.  Q:$D(DIRUT)
  1.  I 'Y W !,"Okay, not deleted." Q
  1.  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
  1.  D BACK
  1.  Q
  1.  ;
  1. WAGE(H,G,A) ;
  1.  NEW X,Y,Z,B,E
  1.  S X=$P(^APCHSURV(H,11,G,11,A,0),U,1)
  1.  S Y=$P(^APCHSURV(H,11,G,11,A,0),U,2)
  1.  I X["Y" S B=+X_$S(+X=1:" year",1:" years")
  1.  I X["D" S B=+X_$S(+X=1:" day",1:" days")
  1.  I X["M" S B=+X_$S(+X=1:" month",1:" months")
  1.  I Y["Y" S E=+Y_$S(+Y=1:" year",1:" years")
  1.  I Y["D" S E=+Y_$S(+Y=1:" day",1:" days")
  1.  I Y["M" S E=+Y_$S(+Y=1:" month",1:" months")
  1.  Q B_"-"_E
  1. WF(H,G,A) ;
  1.  NEW X,Y,Z,B,E
  1.  S X=$P(^APCHSURV(H,11,G,11,A,0),U,3)
  1.  I X["Y" S B=+X_$S(+X=1:" year",1:" years")
  1.  I X["D" S B=+X_$S(+X=1:" day",1:" days")
  1.  I X["M" S B=+X_$S(+X=1:" month",1:" months")
  1.  Q B
  1.  ;
  1. W(A) ;
  1.  NEW B
  1.  I A["Y" S B=+A_$S(+A=1:" year",1:" years")
  1.  I A["D" S B=+A_$S(+A=1:" day",1:" days")
  1.  I A["M" S B=+A_$S(+A=1:" month",1:" months")
  1.  Q B