YTQPXRM1 ;ALB/ASF- MHA3 API FOR CLINICAL REMINDERS ; 2/20/08 10:32am
;;5.01;MENTAL HEALTH;**85,96**;Dec 30, 1994;Build 46
;Reference to ^PXRMINDX(601.2, supported by DBIA #4114
;Reference to ^PXRMINDX(601.84, supported by DBIA #4290
Q
OCCUR(YSSUB,YS) ;occurrences OF TESTS,GAF,ASI
;Input:
;YS("CODE"): Test code NUMBER from file 601.71 including "ASI","GAF"
;YS("BEGIN"): inclusive date in %DT acceptable format (11/11/2011) to begin search [optional]
;YS("END"): inclusive date in %DT acceptable format (11/11/2011) to end search [optional]
;YS("LIMIT"): Last N administrations [optional]
;Output
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
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
D PARSE(.YS)
S N=0
K ^TMP($J,YSSUB)
I YSCODE="ASI" D ASIOC Q ;-->out
I YSCODE="GAF" D GAFOC Q ;-->out
I '$D(^YTT(601.71,"B",YSCODE)) S ^TMP($J,YSSUB,1)="[ERROR]^BAD TEST CODE #" Q ;-->out
S NI=0
PA S DFN=0
F S DFN=$O(^PXRMINDX(601.84,"IP",YSCODEN,DFN)) Q:DFN'>0 S YSOCC=0 D
. S YSN2=YSEND+.0000001 F S YSN2=$O(^PXRMINDX(601.84,"IP",YSCODEN,DFN,YSN2),-1) Q:YSN2'>0!(YSN2<YSBEG) D
.. S DAS=0 F S DAS=$O(^PXRMINDX(601.84,"IP",YSCODEN,DFN,YSN2,DAS)) Q:DAS'>0 D
... S YSOCC=YSOCC+1
... Q:(YSOCC>YSLM)
... S NI=NI+1
... S ^TMP($J,YSSUB,DFN,YSOCC)=DAS_U_YSN2_U_YSCODEN_"^601.84"
P0 S DFN=0,YS601=$O(^YTT(601,"B",YSCODE,0))
Q:YS601="" ;out ASF 2/20/08
F S DFN=$O(^PXRMINDX(601.2,"IP",YS601,DFN)) Q:DFN'>0 S YS("DFN")=DFN D P1
S ^TMP($J,YSSUB)="[DATA]"_U_NI
Q
P1 S YSOCC=$O(^TMP($J,YSSUB,DFN,99999),-1)
S YSN2=YSEND+.1 F S YSN2=$O(^PXRMINDX(601.2,"IP",YS601,DFN,YSN2),-1) Q:YSN2'>0!(YSN2<YSBEG) D
. S YSOCC=YSOCC+1
. Q:(YSOCC>YSLM)
. S NI=NI+1
. S ^TMP($J,YSSUB,DFN,YSOCC)=DFN_";1;"_YS601_";1;"_YSN2_U_YSN2_U_YS601_"^601.2"
Q
PARSE(YS) ; -- array parsing
S DFN=$G(YS("DFN"))
S (YSCODEN,YSCODE)=$G(YS("CODE"))
S YSCODE=$P($G(^YTT(601.71,YSCODE,0),"ERROR"),U)
S YSADATE=$G(YS("ADATE")) S X=YSADATE,%DT="T" D ^%DT S YSADATE=Y
S YSSCALE=$G(YS("SCALE"))
S YSBEG=$G(YS("BEGIN")) S:YSBEG="" YSBEG="01/01/1970" S X=YSBEG,%DT="T" D ^%DT S YSBEG=Y
S YSEND=$G(YS("END")) S:YSEND="" YSEND="01/01/2099" S X=YSEND,%DT="T" D ^%DT S YSEND=Y
S YSLM=$G(YS("LIMIT"),1)
Q
GAFOC ;all axis5 DXs in time frame
S YS601=$O(^YTT(601,"B","GAF",0))
S YST=YSEND+.0000001,NI=0
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
. S X=$P($G(^YSD(627.8,IFN,60)),U,3)
. Q:X=""
. S DFN=$P($G(^YSD(627.8,IFN,0)),U,2) Q:DFN'>0 ;bad dfn
. S YSOCC=$O(^TMP($J,YSSUB,DFN,999999),-1)+1
. Q:(YSOCC>YSLM)
. S NI=NI+1
. S ^TMP($J,YSSUB,DFN,YSOCC)=DFN_";1;"_YS601_";1;"_IFN_U_YST_U_YS601_"^627.8"
S ^TMP($J,YSSUB)="[DATA]"_U_NI
Q
ASIOC ;
S YS601=$O(^YTT(601,"B","ASI",0))
S NI=0,DFN=0,YSID=YSEND+.01
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
. Q:'$D(^YSTX(604,IFN,.5)) ; no sig
. S G=$G(^YSTX(604,IFN,0))
. S DFN=$P(G,U,2) Q:DFN'>0 ;bad dfn
. S YSOCC=$O(^TMP($J,YSSUB,DFN,999999),-1)+1
. Q:(YSOCC>YSLM)
. S NI=NI+1
. S ^TMP($J,YSSUB,DFN,YSOCC)=DFN_";1;"_YS601_";1;"_IFN_U_$P(G,U,5)_U_YS601_"^604"
S ^TMP($J,YSSUB)="[DATA]"_U_NI
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQPXRM1 3467 printed Apr 09, 2024@21:24:38 Page 2
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
+2 ;Reference to ^PXRMINDX(601.2, supported by DBIA #4114
+3 ;Reference to ^PXRMINDX(601.84, supported by DBIA #4290
+4 QUIT
OCCUR(YSSUB,YS) ;occurrences OF TESTS,GAF,ASI
+1 ;Input:
+2 ;YS("CODE"): Test code NUMBER from file 601.71 including "ASI","GAF"
+3 ;YS("BEGIN"): inclusive date in %DT acceptable format (11/11/2011) to begin search [optional]
+4 ;YS("END"): inclusive date in %DT acceptable format (11/11/2011) to end search [optional]
+5 ;YS("LIMIT"): Last N administrations [optional]
+6 ;Output
+7 NEW G,YSLIMIT,YSJJ,YSSONE,S,R,N,YSN2,N4,I,II,DFN,YSCODE,YSCODEN,YSADATE,YSSCALE,YSBED,YSEND,YSAA,DAS,YSOCC,YSZN,YST,YSLM
+8 NEW 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
+9 DO PARSE(.YS)
+10 SET N=0
+11 KILL ^TMP($JOB,YSSUB)
+12 ;-->out
IF YSCODE="ASI"
DO ASIOC
QUIT
+13 ;-->out
IF YSCODE="GAF"
DO GAFOC
QUIT
+14 ;-->out
IF '$DATA(^YTT(601.71,"B",YSCODE))
SET ^TMP($JOB,YSSUB,1)="[ERROR]^BAD TEST CODE #"
QUIT
+15 SET NI=0
PA SET DFN=0
+1 FOR
SET DFN=$ORDER(^PXRMINDX(601.84,"IP",YSCODEN,DFN))
if DFN'>0
QUIT
SET YSOCC=0
Begin DoDot:1
+2 SET YSN2=YSEND+.0000001
FOR
SET YSN2=$ORDER(^PXRMINDX(601.84,"IP",YSCODEN,DFN,YSN2),-1)
if YSN2'>0!(YSN2<YSBEG)
QUIT
Begin DoDot:2
+3 SET DAS=0
FOR
SET DAS=$ORDER(^PXRMINDX(601.84,"IP",YSCODEN,DFN,YSN2,DAS))
if DAS'>0
QUIT
Begin DoDot:3
+4 SET YSOCC=YSOCC+1
+5 if (YSOCC>YSLM)
QUIT
+6 SET NI=NI+1
+7 SET ^TMP($JOB,YSSUB,DFN,YSOCC)=DAS_U_YSN2_U_YSCODEN_"^601.84"
End DoDot:3
End DoDot:2
End DoDot:1
P0 SET DFN=0
SET YS601=$ORDER(^YTT(601,"B",YSCODE,0))
+1 ;out ASF 2/20/08
if YS601=""
QUIT
+2 FOR
SET DFN=$ORDER(^PXRMINDX(601.2,"IP",YS601,DFN))
if DFN'>0
QUIT
SET YS("DFN")=DFN
DO P1
+3 SET ^TMP($JOB,YSSUB)="[DATA]"_U_NI
+4 QUIT
P1 SET YSOCC=$ORDER(^TMP($JOB,YSSUB,DFN,99999),-1)
+1 SET YSN2=YSEND+.1
FOR
SET YSN2=$ORDER(^PXRMINDX(601.2,"IP",YS601,DFN,YSN2),-1)
if YSN2'>0!(YSN2<YSBEG)
QUIT
Begin DoDot:1
+2 SET YSOCC=YSOCC+1
+3 if (YSOCC>YSLM)
QUIT
+4 SET NI=NI+1
+5 SET ^TMP($JOB,YSSUB,DFN,YSOCC)=DFN_";1;"_YS601_";1;"_YSN2_U_YSN2_U_YS601_"^601.2"
End DoDot:1
+6 QUIT
PARSE(YS) ; -- array parsing
+1 SET DFN=$GET(YS("DFN"))
+2 SET (YSCODEN,YSCODE)=$GET(YS("CODE"))
+3 SET YSCODE=$PIECE($GET(^YTT(601.71,YSCODE,0),"ERROR"),U)
+4 SET YSADATE=$GET(YS("ADATE"))
SET X=YSADATE
SET %DT="T"
DO ^%DT
SET YSADATE=Y
+5 SET YSSCALE=$GET(YS("SCALE"))
+6 SET YSBEG=$GET(YS("BEGIN"))
if YSBEG=""
SET YSBEG="01/01/1970"
SET X=YSBEG
SET %DT="T"
DO ^%DT
SET YSBEG=Y
+7 SET YSEND=$GET(YS("END"))
if YSEND=""
SET YSEND="01/01/2099"
SET X=YSEND
SET %DT="T"
DO ^%DT
SET YSEND=Y
+8 SET YSLM=$GET(YS("LIMIT"),1)
+9 QUIT
GAFOC ;all axis5 DXs in time frame
+1 SET YS601=$ORDER(^YTT(601,"B","GAF",0))
+2 SET YST=YSEND+.0000001
SET NI=0
+3 FOR
SET YST=$ORDER(^YSD(627.8,"B",YST),-1)
if YST'>0!(YST<YSBEG)
QUIT
SET IFN=0
FOR
SET IFN=$ORDER(^YSD(627.8,"B",YST,IFN))
if IFN'>0
QUIT
Begin DoDot:1
+4 SET X=$PIECE($GET(^YSD(627.8,IFN,60)),U,3)
+5 if X=""
QUIT
+6 ;bad dfn
SET DFN=$PIECE($GET(^YSD(627.8,IFN,0)),U,2)
if DFN'>0
QUIT
+7 SET YSOCC=$ORDER(^TMP($JOB,YSSUB,DFN,999999),-1)+1
+8 if (YSOCC>YSLM)
QUIT
+9 SET NI=NI+1
+10 SET ^TMP($JOB,YSSUB,DFN,YSOCC)=DFN_";1;"_YS601_";1;"_IFN_U_YST_U_YS601_"^627.8"
End DoDot:1
+11 SET ^TMP($JOB,YSSUB)="[DATA]"_U_NI
+12 QUIT
ASIOC ;
+1 SET YS601=$ORDER(^YTT(601,"B","ASI",0))
+2 SET NI=0
SET DFN=0
SET YSID=YSEND+.01
+3 FOR
SET YSID=$ORDER(^YSTX(604,"AD",YSID),-1)
if (YSID'>0)!(YSID<YSBEG)
QUIT
SET IFN=0
FOR
SET IFN=$ORDER(^YSTX(604,"AD",YSID,IFN))
if IFN'>0
QUIT
Begin DoDot:1
+4 ; no sig
if '$DATA(^YSTX(604,IFN,.5))
QUIT
+5 SET G=$GET(^YSTX(604,IFN,0))
+6 ;bad dfn
SET DFN=$PIECE(G,U,2)
if DFN'>0
QUIT
+7 SET YSOCC=$ORDER(^TMP($JOB,YSSUB,DFN,999999),-1)+1
+8 if (YSOCC>YSLM)
QUIT
+9 SET NI=NI+1
+10 SET ^TMP($JOB,YSSUB,DFN,YSOCC)=DFN_";1;"_YS601_";1;"_IFN_U_$PIECE(G,U,5)_U_YS601_"^604"
End DoDot:1
+11 SET ^TMP($JOB,YSSUB)="[DATA]"_U_NI
+12 QUIT
