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

APCHTP1.m

Go to the documentation of this file.
  1. APCHTP1 ; IHS/CMI/LAB - TP 1 ;
  1. ;;2.0;IHS PCC SUITE;**2,10**;MAY 14, 2009;Build 88
  1. ;
  1. ;
  1. EP ;EP - CALLED FROM OPTION
  1. D EN
  1. Q
  1. EOJ ;EP
  1. D EN^XBVK("APCH")
  1. Q
  1. ;; ;
  1. EN ; -- main entry point for APCH TP DISPLAY
  1. D EN^VALM("APCH TP DISPLAY")
  1. D CLEAR^VALM1
  1. D FULL^VALM1
  1. W:$D(IOF) @IOF
  1. D EOJ
  1. Q
  1. ;
  1. HDR ; -- header code
  1. S VALMHDR(1)="Best Practice Prompt Logic Display"
  1. Q
  1. ;
  1. INIT ; -- init variables and list array
  1. K APCHDISP,APCHSEL,APCHHIGH,APCHLIST,APCHCSEL
  1. S APCHHIGH=0,X=0,N="" F S N=$O(^APCHSURV("B",N)) Q:N="" S X=0 F S X=$O(^APCHSURV("B",N,X)) Q:X'=+X I $P(^APCHSURV(X,0),U,3)'="D",$P(^APCHSURV(X,0),U,7)="T" S APCHHIGH=APCHHIGH+1,APCHSEL(APCHHIGH)=X
  1. S APCHCUT=((APCHHIGH/3)+1)\1
  1. ;S APCHCUT=(APCHHIGH/3)\1
  1. S (C,I)=0,J=1,K=1 F S I=$O(APCHSEL(I)) Q:I'=+I!($D(APCHDISP(I))) D
  1. .S C=C+1,APCHLIST(C,0)=I_") "_$S($D(APCHCSEL(I)):"*",1:" ")_$E($P(^APCHSURV(APCHSEL(I),0),U),1,20) S APCHDISP(I)="",APCHLIST("IDX",C,C)=""
  1. .S J=I+APCHCUT I $D(APCHSEL(J)),'$D(APCHDISP(J)) S $E(APCHLIST(C,0),28)=J_") "_$S($D(APCHCSEL(J)):"*",1:" ")_$E($P(^APCHSURV(APCHSEL(J),0),U),1,20) S APCHDISP(J)=""
  1. .S K=J+APCHCUT I $D(APCHSEL(K)),'$D(APCHDISP(K)) S $E(APCHLIST(C,0),55)=K_") "_$S($D(APCHCSEL(K)):"*",1:" ")_$E($P(^APCHSURV(APCHSEL(K),0),U),1,20) S APCHDISP(K)=""
  1. K APCHDISP
  1. S VALMCNT=C
  1. Q
  1. ;
  1. HELP ; -- help code
  1. S X="?" D DISP^XQORM1 W !!
  1. Q
  1. ;
  1. EXIT ; -- exit code
  1. Q
  1. ;
  1. EXPND ; -- expand code
  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. ADD ;EP - add an item to the selected list - called from a protocol
  1. W ! S DIR(0)="LO^1:"_APCHHIGH,DIR("A")="Which item(s)" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1. I Y="" W !,"No items selected." G ADDX
  1. I $D(DIRUT) W !,"No items selected." G ADDX
  1. D FULL^VALM1 W:$D(IOF) @IOF
  1. S APCHANS=Y,APCHC="" F APCHI=1:1 S APCHC=$P(APCHANS,",",APCHI) Q:APCHC="" S APCHCSEL(APCHC)=""
  1. D DISPLAY
  1. ADDX ;
  1. D BACK
  1. Q
  1. ADDALL ;
  1. F X=1:1:APCHHIGH S APCHCSEL(X)=""
  1. D DISPLAY
  1. D BACK
  1. Q
  1. ;
  1. DISPLAY ;gather in ^TMP and display
  1. K ^TMP("APCHTP1",$J)
  1. S ^TMP("APCHTP1",$J,0)=0
  1. S APCHC=0
  1. S APCHX=0 F S APCHX=$O(APCHCSEL(APCHX)) Q:APCHX'=+APCHX S APCHTP=APCHSEL(APCHX),Y="Best Practice Prompt:",$E(Y,24)=$P(^APCHSURV(APCHTP,0),U) S APCHC=APCHC+1 D S(Y,$S(APCHC=1:0,1:2)) D
  1. .S X="",X="Status:",$E(X,24)=$$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. .I '$O(^APCHSURV(APCHTP,11,0)) S X="<<< No Local Criteria defined >>>" D S(X)
  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. .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 X=$TR($J("",80)," ","*") D S(X,2)
  1. ;
  1. ;
  1. K ^TMP("APCHTP1",$J,0)
  1. D ARRAY^XBLM("^TMP(""APCHTP1"",$J,","BEST PRACTICE PROMPTS DESCRIPTIONS")
  1. Q
  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("APCHTP1",$J,0),U)+1,$P(^TMP("APCHTP1",$J,0),U)=%
  1. S ^TMP("APCHTP1",$J,%,0)=X
  1. Q