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

APCHHMRP.m

Go to the documentation of this file. 
  1. APCHHMRP ; IHS/CMI/LAB - DISPLAY HEALTH MAINTENANCE REMINDER ;
  1.  ;;2.0;IHS PCC SUITE;**2,10**;MAY 14, 2009;Build 88
  1.  ;; ;
  1. EP ;EP - called from option to select and display a hmr
  1.  W !!,"This option will display or print the description/logic of all Health",!,"Summary Maintenance Reminders.",!!
  1. ZIS ;
  1.  S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to ",DIR("B")="P" K DA D ^DIR K DIR
  1.  I $D(DIRUT) G XIT
  1.  I $G(Y)="B" D BROWSE,XIT Q
  1.  S XBRC="PROCESS^APCHHMRP",XBRP="PRINT^APCHHMRP",XBRX="XIT^APCHHMRP",XBNS="APCH"
  1.  D ^XBDBQUE
  1.  D XIT
  1.  Q
  1. XIT ;
  1.  K J,K,X,Z,Y
  1.  D EN^XBVK("APCH")
  1.  Q
  1. BROWSE ;
  1.  S XBRP="VIEWR^XBLM(""PRINT^APCHHMRP"")"
  1.  S XBNS="APCH",XBRC="PROCESS^APCHHMRP",XBRX="XIT^APCHHMRP",XBIOP=0 D ^XBDBQUE
  1.  Q
  1.  ;
  1. PROCESS ; -- init variables and list array
  1.  S APCHJ=$J,APCHH=$H
  1.  S ^XTMP("APCHHMRP",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PCC DATA ENTRY LAB REPORT"
  1.  K ^XTMP("APCHHMRP",APCHJ,APCHH)
  1.  S ^XTMP("APCHHMRP",APCHJ,APCHH,0)=0
  1.  S APCHN="",APCHHMR=0 F  S APCHN=$O(^APCHSURV("B",APCHN)) Q:APCHN=""  S APCHHMR=0 F  S APCHHMR=$O(^APCHSURV("B",APCHN,APCHHMR)) Q:APCHHMR'=+APCHHMR  D PROCESS1
  1.  K ^XTMP("APCHHMRP",APCHJ,APCHH,0)
  1.  Q
  1. PROCESS1 ;
  1.  Q:$P(^APCHSURV(APCHHMR,0),U,3)="D"
  1.  Q:$P(^APCHSURV(APCHHMR,0),U,7)'="R"
  1.  ;gather up reminder for display
  1.  S X="",X="Reminder:",$E(X,20)=$P(^APCHSURV(APCHHMR,0),U) D S(X,1)
  1.  ;S X="",X="Status:",$E(X,20)=$$VAL^XBDIQ1(9001018,APCHHMR,.03) D S(X)
  1.  S X="",X="Category:",$E(X,20)=$$VAL^XBDIQ1(9001018,APCHHMR,.05) D S(X)
  1.  S X="Description:" D S(X,1)
  1.  S Y=0 F  S Y=$O(^APCHSURV(APCHHMR,1,Y)) Q:Y'=+Y  S X="",$E(X,2)=^APCHSURV(APCHHMR,1,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(APCHHMR,11,Y)) Q:Y'=+Y  D
  1.  ;.S Z="",$E(Z,2)="Sex:  "_$S($P(^APCHSURV(APCHHMR,11,Y,0),U)="F":"FEMALE",$P(^APCHSURV(APCHHMR,11,Y,0),U)="M":"MALE",$P(^APCHSURV(APCHHMR,11,Y,0),U)="B":"ALL GENDERS",$P(^APCHSURV(APCHHMR,11,Y,0),U)="U":"UNKNOWN",1:"")
  1.  ;.S J=0 F  S J=$O(^APCHSURV(APCHHMR,11,Y,11,J)) Q:J'=+J  D
  1.  ;..S X=Z,$E(X,21)="Mininum Age: "_$P(^APCHSURV(APCHHMR,11,Y,11,J,0),U),$E(X,40)="Maximum Age: "_$P(^APCHSURV(APCHHMR,11,Y,11,J,0),U,2),$E(X,60)="Frequency: "_$P(^APCHSURV(APCHHMR,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)=APCHHMR S X="",$E(X,15)=$P(^APCHSCTL(J,0),U) D S(X)
  1.  ;.Q
  1.  S X=$TR($J("",80)," ","*") D S(X,2)
  1.  Q
  1.  ;
  1.  ;
  1. PRINT ;EP - called from xbdbque
  1.  S APCHPG=0,APCHQ=0 D HEAD
  1.  S APCHX=0 F  S APCHX=$O(^XTMP("APCHHMRP",APCHJ,APCHH,APCHX)) Q:APCHX'=+APCHX!(APCHQ)  D
  1.  .I $Y>(IOSL-3) D HEAD Q:APCHQ
  1.  .W !,^XTMP("APCHHMRP",APCHJ,APCHH,APCHX)
  1.  .Q
  1.  K ^XTMP("APCHHMRP",APCHJ,APCHH),APCHJ,APCHH
  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(^XTMP("APCHHMRP",APCHJ,APCHH,0),U)+1,$P(^XTMP("APCHHMRP",APCHJ,APCHH,0),U)=%
  1.  S ^XTMP("APCHHMRP",APCHJ,APCHH,%)=X
  1.  Q
  1.  I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQ=1 Q
  1. HEAD1 ;
  1.  W:$D(IOF) @IOF S APCHPG=APCHPG+1
  1.  W !,$P(^VA(200,DUZ,0),U,2),?72,"Page ",APCHPG,!
  1.  W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!
  1.  W $$CTR("HEALTH SUMMARY HEALTH MAINTENANCE REMINDERS",80),!
  1.  W !,$TR($J("",80)," ","-")
  1.  Q
  1.  ;
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. EOP ;EP - End of page.
  1.  Q:$E(IOST)'="C"
  1.  Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1.  NEW DIR
  1.  K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  S DIR(0)="E" D ^DIR
  1.  Q
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------