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

YTQPXRM1.m

Go to the documentation of this file.
  1. YTQPXRM1 ;ALB/ASF- MHA3 API FOR CLINICAL REMINDERS ; 2/20/08 10:32am
  1. ;;5.01;MENTAL HEALTH;**85,96**;Dec 30, 1994;Build 46
  1. ;Reference to ^PXRMINDX(601.2, supported by DBIA #4114
  1. ;Reference to ^PXRMINDX(601.84, supported by DBIA #4290
  1. Q
  1. OCCUR(YSSUB,YS) ;occurrences OF TESTS,GAF,ASI
  1. ;Input:
  1. ;YS("CODE"): Test code NUMBER from file 601.71 including "ASI","GAF"
  1. ;YS("BEGIN"): inclusive date in %DT acceptable format (11/11/2011) to begin search [optional]
  1. ;YS("END"): inclusive date in %DT acceptable format (11/11/2011) to end search [optional]
  1. ;YS("LIMIT"): Last N administrations [optional]
  1. ;Output
  1. N G,YSLIMIT,YSJJ,YSSONE,S,R,N,YSN2,N4,I,II,DFN,YSCODE,YSCODEN,YSADATE,YSSCALE,YSBED,YSEND,YSAA,DAS,YSOCC,YSZN,YST,YSLM
  1. N IFN,R1,R2,R3,SFN1,SFN2,YSBEG,YSCK,YSDFN,YSED,YSIFN,YSINUM,YSITEM,YSN2,YSNODE,YSPRIV,YSQT,YSR,YSSTAFF,YSTYPE,YSCODE,NI,YSID,%DT,X,Y,YS601
  1. D PARSE(.YS)
  1. S N=0
  1. K ^TMP($J,YSSUB)
  1. I YSCODE="ASI" D ASIOC Q ;-->out
  1. I YSCODE="GAF" D GAFOC Q ;-->out
  1. I '$D(^YTT(601.71,"B",YSCODE)) S ^TMP($J,YSSUB,1)="[ERROR]^BAD TEST CODE #" Q ;-->out
  1. S NI=0
  1. PA S DFN=0
  1. F S DFN=$O(^PXRMINDX(601.84,"IP",YSCODEN,DFN)) Q:DFN'>0 S YSOCC=0 D
  1. . S YSN2=YSEND+.0000001 F S YSN2=$O(^PXRMINDX(601.84,"IP",YSCODEN,DFN,YSN2),-1) Q:YSN2'>0!(YSN2<YSBEG) D
  1. .. S DAS=0 F S DAS=$O(^PXRMINDX(601.84,"IP",YSCODEN,DFN,YSN2,DAS)) Q:DAS'>0 D
  1. ... S YSOCC=YSOCC+1
  1. ... Q:(YSOCC>YSLM)
  1. ... S NI=NI+1
  1. ... S ^TMP($J,YSSUB,DFN,YSOCC)=DAS_U_YSN2_U_YSCODEN_"^601.84"
  1. P0 S DFN=0,YS601=$O(^YTT(601,"B",YSCODE,0))
  1. Q:YS601="" ;out ASF 2/20/08
  1. F S DFN=$O(^PXRMINDX(601.2,"IP",YS601,DFN)) Q:DFN'>0 S YS("DFN")=DFN D P1
  1. S ^TMP($J,YSSUB)="[DATA]"_U_NI
  1. Q
  1. P1 S YSOCC=$O(^TMP($J,YSSUB,DFN,99999),-1)
  1. S YSN2=YSEND+.1 F S YSN2=$O(^PXRMINDX(601.2,"IP",YS601,DFN,YSN2),-1) Q:YSN2'>0!(YSN2<YSBEG) D
  1. . S YSOCC=YSOCC+1
  1. . Q:(YSOCC>YSLM)
  1. . S NI=NI+1
  1. . S ^TMP($J,YSSUB,DFN,YSOCC)=DFN_";1;"_YS601_";1;"_YSN2_U_YSN2_U_YS601_"^601.2"
  1. Q
  1. PARSE(YS) ; -- array parsing
  1. S DFN=$G(YS("DFN"))
  1. S (YSCODEN,YSCODE)=$G(YS("CODE"))
  1. S YSCODE=$P($G(^YTT(601.71,YSCODE,0),"ERROR"),U)
  1. S YSADATE=$G(YS("ADATE")) S X=YSADATE,%DT="T" D ^%DT S YSADATE=Y
  1. S YSSCALE=$G(YS("SCALE"))
  1. S YSBEG=$G(YS("BEGIN")) S:YSBEG="" YSBEG="01/01/1970" S X=YSBEG,%DT="T" D ^%DT S YSBEG=Y
  1. S YSEND=$G(YS("END")) S:YSEND="" YSEND="01/01/2099" S X=YSEND,%DT="T" D ^%DT S YSEND=Y
  1. S YSLM=$G(YS("LIMIT"),1)
  1. Q
  1. GAFOC ;all axis5 DXs in time frame
  1. S YS601=$O(^YTT(601,"B","GAF",0))
  1. S YST=YSEND+.0000001,NI=0
  1. F S YST=$O(^YSD(627.8,"B",YST),-1) Q:YST'>0!(YST<YSBEG) S IFN=0 F S IFN=$O(^YSD(627.8,"B",YST,IFN)) Q:IFN'>0 D
  1. . S X=$P($G(^YSD(627.8,IFN,60)),U,3)
  1. . Q:X=""
  1. . S DFN=$P($G(^YSD(627.8,IFN,0)),U,2) Q:DFN'>0 ;bad dfn
  1. . S YSOCC=$O(^TMP($J,YSSUB,DFN,999999),-1)+1
  1. . Q:(YSOCC>YSLM)
  1. . S NI=NI+1
  1. . S ^TMP($J,YSSUB,DFN,YSOCC)=DFN_";1;"_YS601_";1;"_IFN_U_YST_U_YS601_"^627.8"
  1. S ^TMP($J,YSSUB)="[DATA]"_U_NI
  1. Q
  1. ASIOC ;
  1. S YS601=$O(^YTT(601,"B","ASI",0))
  1. S NI=0,DFN=0,YSID=YSEND+.01
  1. F S YSID=$O(^YSTX(604,"AD",YSID),-1) Q:(YSID'>0)!(YSID<YSBEG) S IFN=0 F S IFN=$O(^YSTX(604,"AD",YSID,IFN)) Q:IFN'>0 D
  1. . Q:'$D(^YSTX(604,IFN,.5)) ; no sig
  1. . S G=$G(^YSTX(604,IFN,0))
  1. . S DFN=$P(G,U,2) Q:DFN'>0 ;bad dfn
  1. . S YSOCC=$O(^TMP($J,YSSUB,DFN,999999),-1)+1
  1. . Q:(YSOCC>YSLM)
  1. . S NI=NI+1
  1. . S ^TMP($J,YSSUB,DFN,YSOCC)=DFN_";1;"_YS601_";1;"_IFN_U_$P(G,U,5)_U_YS601_"^604"
  1. S ^TMP($J,YSSUB)="[DATA]"_U_NI
  1. Q