- 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 Feb 18, 2025@23:44:50 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