YTQPXRM2.m

YTQPXRM2 ;ALB/ASF- MHA3 API FOR CLINICAL REMINDERS ; 7/27/07 1:25pm

 ;;5.01;MENTAL HEALTH;**85,119**;Dec 30, 1994;Build 40

 ;Reference to ^PXRMINDX(601.2, supported by DBIA #4114

 ;Reference to ^PXRMINDX(601.84, supported by DBIA #4290

 ;

 ;The following entry points are documented in ICR 5035:

 ; PTTEST

 Q

PTTEST(YSDATA,YS) ;all data scores for a specific patient

 ;Input:

 ;YS("DFN"): Patient IFN from file2

 ;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

 ;YSDATA(1)=[DATA]^NUMBER FOUND

 ;YSDATA(OCCURRENCE,1:999) most recent to least recent occurrence for this test for this patient

 N YSBEG,YSCODE,R1,R2,R3,YSADATE,YSEND,YSLIMIT,YSLM,YSOCC,YSSCALE,YSSTAFF,YSZ,YSZN,G,YSORT,YSCODEN,YS601,%DT,DAS,DFN,IFN,NI,N,N1,N2,YSID,X,Y,YSNEG,YSDFN

 K ^TMP($J,"YSG"),YSDATA

 D PARSE(.YS)

 I YSLM'?1NP.N!(YSLM=0) S YSDATA(1)="[ERROR]",YSDATA(2)="bad limit" Q  ;-->out

 I YSLM>0 S YSNEG=0,YSORT=-1

 E  S YSLM=YSLM*-1,YSNEG=1,YSORT=1

 I YSCODE="ASI" D ASIPT Q  ;-->out

 I YSCODE="GAF" D GAFPT Q  ;-->out

 D P1,PA

 S NI=0

 I YSNEG=0 S N=9999999 F  S N=$O(^TMP($J,"YSG",N),-1) Q:N=""!(NI=YSLM)  D

 . S N2=9999999 F  S N2=$O(^TMP($J,"YSG",N,N2),-1) Q:N2=""!(NI=YSLM)  S NI=NI+1,YSDATA(NI+1)=^TMP($J,"YSG",N,N2)

 I YSNEG=1 S N=0 F  S N=$O(^TMP($J,"YSG",N)) Q:N=""!(NI=YSLM)  D

 . S N2=0 F  S N2=$O(^TMP($J,"YSG",N,N2)) Q:N2=""  S NI=NI+1,YSDATA(NI+1)=^TMP($J,"YSG",N,N2)

 S YSDATA(1)="[DATA]"_U_NI

 K ^TMP($J,"YSG"),YS

 Q

PA ;MHA3 DATA

 I YSNEG=0 S YSID=YSEND+.00001

 E  S YSID=YSBEG-.00001

 S NI=0

 F  S YSID=$O(^PXRMINDX(601.84,"PI",DFN,YSCODEN,YSID),YSORT) Q:(YSID'>0)!(YSID<YSBEG)!(YSID>YSEND)  D

 . S DAS=0 F  S DAS=$O(^PXRMINDX(601.84,"PI",DFN,YSCODEN,YSID,DAS)) Q:DAS'>0!(NI=YSLM)  D

 .. S NI=NI+1

 .. S ^TMP($J,"YSG",YSID,NI)=DAS_U_YSID_"^601.84"

 Q

P1 ;old 601.2 data

 I YSNEG=0 S YSID=YSEND+.00001

 E  S YSID=YSBEG-.00001

 S NI=0

 S YS601=$O(^YTT(601,"B",YSCODE,0))

 Q:YS601=""  ;-->out ASF 2/23/07

 F  S YSID=$O(^PXRMINDX(601.2,"PI",DFN,YS601,YSID),YSORT) Q:(YSID'>0)!(YSID<YSBEG)!(YSID>YSEND)!(NI=YSLM)  D

 . S DAS=DFN_";1;"_YS601_";1;"_YSID

 . S NI=NI+1

 . S ^TMP($J,"YSG",YSID,NI)=DAS_U_YSID_"^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,YSCODEN,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\1

 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

GAFPT ;gaf for pt IN time

 S YS601=$O(^YTT(601,"B","GAF",0))

 S IFN=$S(YSORT=1:0,1:9999999),NI=0

 K ^TMP($J,"YSGAF")

 F  S IFN=$O(^YSD(627.8,"C",DFN,IFN),YSORT) Q:(IFN'>0)!(NI=YSLM)  D

 . S X=$P($G(^YSD(627.8,IFN,60)),U,3)

 . Q:X=""

 . S X=+$P($G(^YSD(627.8,IFN,0)),U,3) ;FT  6/7/12 Remedy #391317

 . Q:(X<YSBEG)!(X>YSEND)

 . S NI=NI+1

 . S ^TMP($J,"YSGAF",X,IFN)=""

 S X=$S(YSORT=1:0,1:9999999)

 F  S X=$O(^TMP($J,"YSGAF",X),YSORT) Q:X'>0  S IFN=0 F  S IFN=$O(^TMP($J,"YSGAF",X,IFN)) Q:IFN'>0  D

 . S YSOCC=$O(YSDATA(9999999),-1)+1 S:YSOCC<2 YSOCC=2

 . S DAS=DFN_";1;"_YS601_";1;"_IFN

 . S YSDATA(YSOCC)=DAS_U_X_"^627.8"

 S YSDATA(1)="[DATA]"_U_NI

 Q

ASIPT ;asis for pt IN time

 S YS601=$O(^YTT(601,"B","ASI",0))

 S IFN=$S(YSORT=1:0,1:9999999),NI=0

 F  S IFN=$O(^YSTX(604,"C",DFN,IFN),YSORT) Q:IFN'>0!(NI=YSLM)  D

 . Q:'$D(^YSTX(604,IFN,.5))  ; no sig

 . S X=$P($G(^YSTX(604,IFN,0)),U,5)

 . Q:X=""

 . Q:(X<YSBEG)!(X>YSEND)

 . S YSOCC=$O(YSDATA(9999999),-1)+1 S:YSOCC<2 YSOCC=2

 . S NI=NI+1

 . S DAS=DFN_";1;"_YS601_";1;"_IFN

 . S YSDATA(YSOCC)=DAS_U_X_"^604"

 S YSDATA(1)="[DATA]"_U_NI

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---YTQPXRM2   4023     printed  Apr 23, 2025@18:32:59                                                                                                                                                                                                    Page 2

YTQPXRM2  ;ALB/ASF- MHA3 API FOR CLINICAL REMINDERS ; 7/27/07 1:25pm

 +1       ;;5.01;MENTAL HEALTH;**85,119**;Dec 30, 1994;Build 40

 +2       ;Reference to ^PXRMINDX(601.2, supported by DBIA #4114

 +3       ;Reference to ^PXRMINDX(601.84, supported by DBIA #4290

 +4       ;

 +5       ;The following entry points are documented in ICR 5035:

 +6       ; PTTEST

 +7        QUIT 

PTTEST(YSDATA,YS) ;all data scores for a specific patient

 +1       ;Input:

 +2       ;YS("DFN"): Patient IFN from file2

 +3       ;YS("CODE"): Test code NUMBER from file 601.71 including "ASI","GAF"

 +4       ;YS("BEGIN"): inclusive date in %DT acceptable format (11/11/2011) to begin search [optional]                

 +5       ;YS("END"): inclusive date in %DT acceptable format (11/11/2011) to end search  [optional]           

 +6       ;YS("LIMIT"): Last N administrations [optional]

 +7       ;Output

 +8       ;YSDATA(1)=[DATA]^NUMBER FOUND

 +9       ;YSDATA(OCCURRENCE,1:999) most recent to least recent occurrence for this test for this patient

 +10       NEW YSBEG,YSCODE,R1,R2,R3,YSADATE,YSEND,YSLIMIT,YSLM,YSOCC,YSSCALE,YSSTAFF,YSZ,YSZN,G,YSORT,YSCODEN,YS601,%DT,DAS,DFN,IFN,NI,N,N1,N2,YSID,X,Y,YSNEG,YSDFN

 +11       KILL ^TMP($JOB,"YSG"),YSDATA

 +12       DO PARSE(.YS)

 +13      ;-->out

           IF YSLM'?1NP.N!(YSLM=0)

               SET YSDATA(1)="[ERROR]"

               SET YSDATA(2)="bad limit"

               QUIT 

 +14       IF YSLM>0

               SET YSNEG=0

               SET YSORT=-1

 +15      IF '$TEST

               SET YSLM=YSLM*-1

               SET YSNEG=1

               SET YSORT=1

 +16      ;-->out

           IF YSCODE="ASI"

               DO ASIPT

               QUIT 

 +17      ;-->out

           IF YSCODE="GAF"

               DO GAFPT

               QUIT 

 +18       DO P1

           DO PA

 +19       SET NI=0

 +20       IF YSNEG=0

               SET N=9999999

               FOR 

                   SET N=$ORDER(^TMP($JOB,"YSG",N),-1)

                   if N=""!(NI=YSLM)

                       QUIT 

                   Begin DoDot:1

 +21                   SET N2=9999999

                       FOR 

                           SET N2=$ORDER(^TMP($JOB,"YSG",N,N2),-1)

                           if N2=""!(NI=YSLM)

                               QUIT 

                           SET NI=NI+1

                           SET YSDATA(NI+1)=^TMP($JOB,"YSG",N,N2)

                   End DoDot:1

 +22       IF YSNEG=1

               SET N=0

               FOR 

                   SET N=$ORDER(^TMP($JOB,"YSG",N))

                   if N=""!(NI=YSLM)

                       QUIT 

                   Begin DoDot:1

 +23                   SET N2=0

                       FOR 

                           SET N2=$ORDER(^TMP($JOB,"YSG",N,N2))

                           if N2=""

                               QUIT 

                           SET NI=NI+1

                           SET YSDATA(NI+1)=^TMP($JOB,"YSG",N,N2)

                   End DoDot:1

 +24       SET YSDATA(1)="[DATA]"_U_NI

 +25       KILL ^TMP($JOB,"YSG"),YS

 +26       QUIT 

PA        ;MHA3 DATA

 +1        IF YSNEG=0

               SET YSID=YSEND+.00001

 +2       IF '$TEST

               SET YSID=YSBEG-.00001

 +3        SET NI=0

 +4        FOR 

               SET YSID=$ORDER(^PXRMINDX(601.84,"PI",DFN,YSCODEN,YSID),YSORT)

               if (YSID'>0)!(YSID<YSBEG)!(YSID>YSEND)

                   QUIT 

               Begin DoDot:1

 +5                SET DAS=0

                   FOR 

                       SET DAS=$ORDER(^PXRMINDX(601.84,"PI",DFN,YSCODEN,YSID,DAS))

                       if DAS'>0!(NI=YSLM)

                           QUIT 

                       Begin DoDot:2

 +6                        SET NI=NI+1

 +7                        SET ^TMP($JOB,"YSG",YSID,NI)=DAS_U_YSID_"^601.84"

                       End DoDot:2

               End DoDot:1

 +8        QUIT 

P1        ;old 601.2 data

 +1        IF YSNEG=0

               SET YSID=YSEND+.00001

 +2       IF '$TEST

               SET YSID=YSBEG-.00001

 +3        SET NI=0

 +4        SET YS601=$ORDER(^YTT(601,"B",YSCODE,0))

 +5       ;-->out ASF 2/23/07

           if YS601=""

               QUIT 

 +6        FOR 

               SET YSID=$ORDER(^PXRMINDX(601.2,"PI",DFN,YS601,YSID),YSORT)

               if (YSID'>0)!(YSID<YSBEG)!(YSID>YSEND)!(NI=YSLM)

                   QUIT 

               Begin DoDot:1

 +7                SET DAS=DFN_";1;"_YS601_";1;"_YSID

 +8                SET NI=NI+1

 +9                SET ^TMP($JOB,"YSG",YSID,NI)=DAS_U_YSID_"^601.2"

               End DoDot:1

 +10       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,YSCODEN,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\1

 +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 

GAFPT     ;gaf for pt IN time

 +1        SET YS601=$ORDER(^YTT(601,"B","GAF",0))

 +2        SET IFN=$SELECT(YSORT=1:0,1:9999999)

           SET NI=0

 +3        KILL ^TMP($JOB,"YSGAF")

 +4        FOR 

               SET IFN=$ORDER(^YSD(627.8,"C",DFN,IFN),YSORT)

               if (IFN'>0)!(NI=YSLM)

                   QUIT 

               Begin DoDot:1

 +5                SET X=$PIECE($GET(^YSD(627.8,IFN,60)),U,3)

 +6                if X=""

                       QUIT 

 +7       ;FT  6/7/12 Remedy #391317

                   SET X=+$PIECE($GET(^YSD(627.8,IFN,0)),U,3)

 +8                if (X<YSBEG)!(X>YSEND)

                       QUIT 

 +9                SET NI=NI+1

 +10               SET ^TMP($JOB,"YSGAF",X,IFN)=""

               End DoDot:1

 +11       SET X=$SELECT(YSORT=1:0,1:9999999)

 +12       FOR 

               SET X=$ORDER(^TMP($JOB,"YSGAF",X),YSORT)

               if X'>0

                   QUIT 

               SET IFN=0

               FOR 

                   SET IFN=$ORDER(^TMP($JOB,"YSGAF",X,IFN))

                   if IFN'>0

                       QUIT 

                   Begin DoDot:1

 +13                   SET YSOCC=$ORDER(YSDATA(9999999),-1)+1

                       if YSOCC<2

                           SET YSOCC=2

 +14                   SET DAS=DFN_";1;"_YS601_";1;"_IFN

 +15                   SET YSDATA(YSOCC)=DAS_U_X_"^627.8"

                   End DoDot:1

 +16       SET YSDATA(1)="[DATA]"_U_NI

 +17       QUIT 

ASIPT     ;asis for pt IN time

 +1        SET YS601=$ORDER(^YTT(601,"B","ASI",0))

 +2        SET IFN=$SELECT(YSORT=1:0,1:9999999)

           SET NI=0

 +3        FOR 

               SET IFN=$ORDER(^YSTX(604,"C",DFN,IFN),YSORT)

               if IFN'>0!(NI=YSLM)

                   QUIT 

               Begin DoDot:1

 +4       ; no sig

                   if '$DATA(^YSTX(604,IFN,.5))

                       QUIT 

 +5                SET X=$PIECE($GET(^YSTX(604,IFN,0)),U,5)

 +6                if X=""

                       QUIT 

 +7                if (X<YSBEG)!(X>YSEND)

                       QUIT 

 +8                SET YSOCC=$ORDER(YSDATA(9999999),-1)+1

                   if YSOCC<2

                       SET YSOCC=2

 +9                SET NI=NI+1

 +10               SET DAS=DFN_";1;"_YS601_";1;"_IFN

 +11               SET YSDATA(YSOCC)=DAS_U_X_"^604"

               End DoDot:1

 +12       SET YSDATA(1)="[DATA]"_U_NI

 +13       QUIT