- YTQPXRM6 ;ASF/ALB CLINICAL REMINDERS CONT ; 11/15/07 10:57am
- ;;5.01;MENTAL HEALTH;**85,119**;DEC 30,1994;Build 40
- ;
- Q
- CONVERT(YSDATA,YS) ;convet 601 ien into 601.71 iens
- ;input YS601 AS 601 IEN
- ;output 601.71 ien
- N YS601,YS60171,YSCODE,YSOP
- S YS601=$G(YS("YS601"),0)
- I YS601=0 S YSDATA(1)="[ERROR]",YSDATA(2)="NO code" Q ;-->out
- S YSCODE=$P($G(^YTT(601,YS601,0)),U)
- I YSCODE'?2AN.E S YSDATA(1)="[ERROR]",YSDATA(2)="bad 601" Q ;-->out
- S YS60171=$O(^YTT(601.71,"B",YSCODE,0))
- I YS60171'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="no 71 entry" Q ;-->out
- S YSOP=$P($G(^YTT(601.71,YS60171,2)),U,2)
- I YSOP="D" S YSDATA(1)="[DATA]",YSDATA(2)=YS60171_U_"dropped" Q ;-->out
- S YSDATA(1)="[DATA]",YSDATA(2)=YS60171_U_YSCODE
- Q
- PRIVL(YSDATA,YS) ;check privileges
- N YSCODE,YSET,YSKEY
- S YSCODE=$G(YS("CODE"),-1)
- I (YSCODE="GAF")!(YSCODE="ASI") S YSDATA(1)="[DATA]",YSDATA(2)="1^exempt test" Q ;-->out test exempt
- I '$D(^YTT(601.71,"B",YSCODE)) S YSDATA(1)="[ERROR]",YSDATA(2)="BAD TEST CODE" Q ;--> out
- S YSET=$O(^YTT(601.71,"B",YSCODE,0))
- S YSDATA(1)="[DATA]"
- S YSKEY=$$GET1^DIQ(601.71,YSET_",",9)
- I YSKEY="" S YSDATA(2)="1^exempt test" Q ;-->out
- I $D(^XUSEC(YSKEY,DUZ)) S YSDATA(2)="1^user privileged" Q ;-->out has key
- S YSDATA(2)="0^no access"
- Q
- MHA3CODE(X) ;function to return mha3 test NAME from ien of 601.71
- ;ie S YS("CODE")=$$MHA3CODE^YTQPXRM6(1) sets YS("CODE")="MMPI2"
- S X=$$GET1^DIQ(601.71,X_",",.01)
- Q X
- ENDAS71(YSDATA,DAS) ;single administration output
- ;Input
- ;DAS from ^PXRMINDX(
- ;Output:
- ;Array(1)=[DATA]
- ;Array(2)= Patient Name^Test Code^Test Title^Internal Admin date^External Admin Date ^Ordered by
- ;Array("R",running number)=MH Administration IEN^MH Answer IEN^MH Question IEN^MH Choice IEN [if avail]^MH Legacy answer [single character answer is available^text of answer [first 200 chars]
- ;Array("SI",601.87 IEN)=S_running number1^Scale Name^Raw Score^Transformed Score
- N J,G,N1,N2,YSNAME,YSDATEE,YSDATEI,YSCODE,YSCODEN,YSORD,YSPRT,YSAID,YSADATE,YSA,YSLEG,YSCIS,YSZZ,YSTEXT,YSQID,YSDFN,YSIZE,YSC1,YSCALE1,YSG1,YSRT,YSRTI,YSXXZ
- I DAS?.E1";".E D LEGDAS^YTQPXRM7(.YSDATA,DAS) D SS,SILEG Q ;--> use old rts
- I '$D(^YTT(601.84,DAS,0)) S YSDATA(1)="[ERROR]",YSDATA(2)="bad das" Q ;-->out
- S YSDATA(1)="[DATA]"
- S YSNAME=$$GET1^DIQ(601.84,DAS_",",1)
- S YSCODE=$$GET1^DIQ(601.84,DAS_",",2)
- S YSCODEN=$$GET1^DIQ(601.84,DAS_",",2,"I")
- S YSORD=$$GET1^DIQ(601.84,DAS_",",5)
- S YSDATEE=$$GET1^DIQ(601.84,DAS_",",3)
- S YSDATEI=$$GET1^DIQ(601.84,DAS_",",3,"I")
- S YSPRT=$P(^YTT(601.71,YSCODEN,0),U,3)
- S YSDATA(2)=YSNAME_U_YSCODE_U_YSPRT_U_YSDATEI_U_YSDATEE_U_YSORD
- I $P($G(^YTT(601.71,YSCODEN,9)),"^",1,2)="DLL^YTSCORE" D Q ;-->out
- . S YSDATA(1)="[ERROR]",YSDATA(2)="scored by DLL only"
- ;ASF 11/15/07
- S YSAID=0,N1=0 F S YSAID=$O(^YTT(601.85,"AD",DAS,YSAID)) Q:YSAID'>0 Q:'$D(^YTT(601.85,YSAID,0)) S N1=N1+1 D
- . S (YSTEXT,YSLEG)=""
- . S YSA=^YTT(601.85,YSAID,0),YSCIS=$P(YSA,U,4),YSQID=$P(YSA,U,3)
- . I $D(^YTT(601.85,YSAID,1,1,0)) S YSIZE=0,YSTEXT="",J=0 D S YSTEXT=$E(YSTEXT,2,201)
- .. F S J=$O(^YTT(601.85,1,J)) Q:J'>0!(YSIZE>200) S YSTEXT=" "_^YTT(601.85,YSAID,1,J,0),YSIZE=$L(YSTEXT)
- . S:YSCIS?1N.N YSLEG=$P($G(^YTT(601.75,YSCIS,0)),U,2),YSTEXT=$G(^YTT(601.75,YSCIS,1))
- . S:$D(^YTT(601.85,YSAID,1,1,0)) YSTEXT=^YTT(601.85,YSAID,1,1,0)
- . S YSDATA("R",N1)=DAS_U_YSAID_U_YSQID_U_YSCIS_U_YSLEG_U_YSTEXT
- D SS
- S YS("AD")=DAS D GETSCORE^YTQAPI8(.YSZZ,.YS)
- D SI
- Q
- UCASE(X) ;upper case
- N %
- F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)
- Q X
- SS ;scale listing
- S:DAS?.E1";".E YSCODEN=$O(^YTT(601.71,"B",YSCODEN,0))
- D SCALES^YTQPXRM5(.YSQQ,YSCODEN)
- S N2=0 F S N2=$O(YSQQ("S",N2)) Q:N2'>0 D
- . S YSCALE1=YSQQ("S",N2)
- . S YSC1($$UCASE(YSCALE1),N2)=""
- K YSQQ
- Q
- SI ;set internal scale walk
- S N2=1 F S N2=$O(^TMP($J,"YSCOR",N2)) Q:N2'>0 D
- . S YSG1=^TMP($J,"YSCOR",N2)
- . S YSCALE1=$P(YSG1,"="),YSRT=$P(YSG1,"=",2)
- . ;S YSDATA("S",N2-1)="S"_(N2-1)_U_YSCALE1_U_YSRT
- . S YSRTI=$O(YSC1($$UCASE(YSCALE1),0))
- . S:YSRTI'="" YSDATA("SI",YSRTI)="S"_(N2-1)_U_YSCALE1_U_YSRT
- K ^TMP($J,"YSCOR"),^TMP($J,"YSG"),YS
- Q
- SILEG ;legacy internal walk
- S N2=0 F S N2=$O(YSDATA("S",N2)) Q:N2'>0 D
- . S YSG1=YSDATA("S",N2),YSCALE1=$P(YSG1,U,2),YSRT=$P(YSG1,U,3,4)
- . S YSRTI=$O(YSC1($$UCASE(YSCALE1),0))
- . S:YSRTI'="" YSDATA("SI",YSRTI)="S"_(N2)_U_YSCALE1_U_YSRT
- K YSDATA("S")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQPXRM6 4444 printed Jan 18, 2025@03:19:45 Page 2
- YTQPXRM6 ;ASF/ALB CLINICAL REMINDERS CONT ; 11/15/07 10:57am
- +1 ;;5.01;MENTAL HEALTH;**85,119**;DEC 30,1994;Build 40
- +2 ;
- +3 QUIT
- CONVERT(YSDATA,YS) ;convet 601 ien into 601.71 iens
- +1 ;input YS601 AS 601 IEN
- +2 ;output 601.71 ien
- +3 NEW YS601,YS60171,YSCODE,YSOP
- +4 SET YS601=$GET(YS("YS601"),0)
- +5 ;-->out
- IF YS601=0
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="NO code"
- QUIT
- +6 SET YSCODE=$PIECE($GET(^YTT(601,YS601,0)),U)
- +7 ;-->out
- IF YSCODE'?2AN.E
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="bad 601"
- QUIT
- +8 SET YS60171=$ORDER(^YTT(601.71,"B",YSCODE,0))
- +9 ;-->out
- IF YS60171'>0
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="no 71 entry"
- QUIT
- +10 SET YSOP=$PIECE($GET(^YTT(601.71,YS60171,2)),U,2)
- +11 ;-->out
- IF YSOP="D"
- SET YSDATA(1)="[DATA]"
- SET YSDATA(2)=YS60171_U_"dropped"
- QUIT
- +12 SET YSDATA(1)="[DATA]"
- SET YSDATA(2)=YS60171_U_YSCODE
- +13 QUIT
- PRIVL(YSDATA,YS) ;check privileges
- +1 NEW YSCODE,YSET,YSKEY
- +2 SET YSCODE=$GET(YS("CODE"),-1)
- +3 ;-->out test exempt
- IF (YSCODE="GAF")!(YSCODE="ASI")
- SET YSDATA(1)="[DATA]"
- SET YSDATA(2)="1^exempt test"
- QUIT
- +4 ;--> out
- IF '$DATA(^YTT(601.71,"B",YSCODE))
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="BAD TEST CODE"
- QUIT
- +5 SET YSET=$ORDER(^YTT(601.71,"B",YSCODE,0))
- +6 SET YSDATA(1)="[DATA]"
- +7 SET YSKEY=$$GET1^DIQ(601.71,YSET_",",9)
- +8 ;-->out
- IF YSKEY=""
- SET YSDATA(2)="1^exempt test"
- QUIT
- +9 ;-->out has key
- IF $DATA(^XUSEC(YSKEY,DUZ))
- SET YSDATA(2)="1^user privileged"
- QUIT
- +10 SET YSDATA(2)="0^no access"
- +11 QUIT
- MHA3CODE(X) ;function to return mha3 test NAME from ien of 601.71
- +1 ;ie S YS("CODE")=$$MHA3CODE^YTQPXRM6(1) sets YS("CODE")="MMPI2"
- +2 SET X=$$GET1^DIQ(601.71,X_",",.01)
- +3 QUIT X
- ENDAS71(YSDATA,DAS) ;single administration output
- +1 ;Input
- +2 ;DAS from ^PXRMINDX(
- +3 ;Output:
- +4 ;Array(1)=[DATA]
- +5 ;Array(2)= Patient Name^Test Code^Test Title^Internal Admin date^External Admin Date ^Ordered by
- +6 ;Array("R",running number)=MH Administration IEN^MH Answer IEN^MH Question IEN^MH Choice IEN [if avail]^MH Legacy answer [single character answer is available^text of answer [first 200 chars]
- +7 ;Array("SI",601.87 IEN)=S_running number1^Scale Name^Raw Score^Transformed Score
- +8 NEW J,G,N1,N2,YSNAME,YSDATEE,YSDATEI,YSCODE,YSCODEN,YSORD,YSPRT,YSAID,YSADATE,YSA,YSLEG,YSCIS,YSZZ,YSTEXT,YSQID,YSDFN,YSIZE,YSC1,YSCALE1,YSG1,YSRT,YSRTI,YSXXZ
- +9 ;--> use old rts
- IF DAS?.E1";".E
- DO LEGDAS^YTQPXRM7(.YSDATA,DAS)
- DO SS
- DO SILEG
- QUIT
- +10 ;-->out
- IF '$DATA(^YTT(601.84,DAS,0))
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="bad das"
- QUIT
- +11 SET YSDATA(1)="[DATA]"
- +12 SET YSNAME=$$GET1^DIQ(601.84,DAS_",",1)
- +13 SET YSCODE=$$GET1^DIQ(601.84,DAS_",",2)
- +14 SET YSCODEN=$$GET1^DIQ(601.84,DAS_",",2,"I")
- +15 SET YSORD=$$GET1^DIQ(601.84,DAS_",",5)
- +16 SET YSDATEE=$$GET1^DIQ(601.84,DAS_",",3)
- +17 SET YSDATEI=$$GET1^DIQ(601.84,DAS_",",3,"I")
- +18 SET YSPRT=$PIECE(^YTT(601.71,YSCODEN,0),U,3)
- +19 SET YSDATA(2)=YSNAME_U_YSCODE_U_YSPRT_U_YSDATEI_U_YSDATEE_U_YSORD
- +20 ;-->out
- IF $PIECE($GET(^YTT(601.71,YSCODEN,9)),"^",1,2)="DLL^YTSCORE"
- Begin DoDot:1
- +21 SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="scored by DLL only"
- End DoDot:1
- QUIT
- +22 ;ASF 11/15/07
- +23 SET YSAID=0
- SET N1=0
- FOR
- SET YSAID=$ORDER(^YTT(601.85,"AD",DAS,YSAID))
- if YSAID'>0
- QUIT
- if '$DATA(^YTT(601.85,YSAID,0))
- QUIT
- SET N1=N1+1
- Begin DoDot:1
- +24 SET (YSTEXT,YSLEG)=""
- +25 SET YSA=^YTT(601.85,YSAID,0)
- SET YSCIS=$PIECE(YSA,U,4)
- SET YSQID=$PIECE(YSA,U,3)
- +26 IF $DATA(^YTT(601.85,YSAID,1,1,0))
- SET YSIZE=0
- SET YSTEXT=""
- SET J=0
- Begin DoDot:2
- +27 FOR
- SET J=$ORDER(^YTT(601.85,1,J))
- if J'>0!(YSIZE>200)
- QUIT
- SET YSTEXT=" "_^YTT(601.85,YSAID,1,J,0)
- SET YSIZE=$LENGTH(YSTEXT)
- End DoDot:2
- SET YSTEXT=$EXTRACT(YSTEXT,2,201)
- +28 if YSCIS?1N.N
- SET YSLEG=$PIECE($GET(^YTT(601.75,YSCIS,0)),U,2)
- SET YSTEXT=$GET(^YTT(601.75,YSCIS,1))
- +29 if $DATA(^YTT(601.85,YSAID,1,1,0))
- SET YSTEXT=^YTT(601.85,YSAID,1,1,0)
- +30 SET YSDATA("R",N1)=DAS_U_YSAID_U_YSQID_U_YSCIS_U_YSLEG_U_YSTEXT
- End DoDot:1
- +31 DO SS
- +32 SET YS("AD")=DAS
- DO GETSCORE^YTQAPI8(.YSZZ,.YS)
- +33 DO SI
- +34 QUIT
- UCASE(X) ;upper case
- +1 NEW %
- +2 FOR %=1:1:$LENGTH(X)
- if $EXTRACT(X,%)?1L
- SET X=$EXTRACT(X,0,%-1)_$CHAR($ASCII(X,%)-32)_$EXTRACT(X,%+1,999)
- +3 QUIT X
- SS ;scale listing
- +1 if DAS?.E1";".E
- SET YSCODEN=$ORDER(^YTT(601.71,"B",YSCODEN,0))
- +2 DO SCALES^YTQPXRM5(.YSQQ,YSCODEN)
- +3 SET N2=0
- FOR
- SET N2=$ORDER(YSQQ("S",N2))
- if N2'>0
- QUIT
- Begin DoDot:1
- +4 SET YSCALE1=YSQQ("S",N2)
- +5 SET YSC1($$UCASE(YSCALE1),N2)=""
- End DoDot:1
- +6 KILL YSQQ
- +7 QUIT
- SI ;set internal scale walk
- +1 SET N2=1
- FOR
- SET N2=$ORDER(^TMP($JOB,"YSCOR",N2))
- if N2'>0
- QUIT
- Begin DoDot:1
- +2 SET YSG1=^TMP($JOB,"YSCOR",N2)
- +3 SET YSCALE1=$PIECE(YSG1,"=")
- SET YSRT=$PIECE(YSG1,"=",2)
- +4 ;S YSDATA("S",N2-1)="S"_(N2-1)_U_YSCALE1_U_YSRT
- +5 SET YSRTI=$ORDER(YSC1($$UCASE(YSCALE1),0))
- +6 if YSRTI'=""
- SET YSDATA("SI",YSRTI)="S"_(N2-1)_U_YSCALE1_U_YSRT
- End DoDot:1
- +7 KILL ^TMP($JOB,"YSCOR"),^TMP($JOB,"YSG"),YS
- +8 QUIT
- SILEG ;legacy internal walk
- +1 SET N2=0
- FOR
- SET N2=$ORDER(YSDATA("S",N2))
- if N2'>0
- QUIT
- Begin DoDot:1
- +2 SET YSG1=YSDATA("S",N2)
- SET YSCALE1=$PIECE(YSG1,U,2)
- SET YSRT=$PIECE(YSG1,U,3,4)
- +3 SET YSRTI=$ORDER(YSC1($$UCASE(YSCALE1),0))
- +4 if YSRTI'=""
- SET YSDATA("SI",YSRTI)="S"_(N2)_U_YSCALE1_U_YSRT
- End DoDot:1
- +5 KILL YSDATA("S")
- +6 QUIT