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

YTSVR12.m

Go to the documentation of this file.
  1. YTSVR12 ;SLC/LLH - Score VR12 ; 01/08/2016
  1. ;;5.01;MENTAL HEALTH;**123**;DEC 30,1994;Build 73
  1. ;
  1. ;Public, Supported ICRs
  1. ; #2056 - Fileman API - $$GET1^DIQ
  1. ;
  1. Q
  1. ;
  1. SETSC(DES,LEG) ;
  1. N QUES,ANS
  1. S QUES=$E(DES)
  1. I QUES=1 Q $S(LEG=1:100,LEG=2:85,LEG=3:60,LEG=4:35,1:"")
  1. I QUES=2 Q $S(LEG'="":((LEG-1)*50),1:"")
  1. I (QUES>2)&(QUES<6) Q $S(LEG'="":((5-LEG)*25),1:"")
  1. I QUES=6 D Q ANS
  1. .I $E(DES,2)'="C" S ANS=$S(LEG'="":((6-LEG)*20),1:"")
  1. .I $E(DES,2)="C" S ANS=$S(LEG'="":((LEG-1)*20),1:"")
  1. I QUES=7 Q $S(LEG'="":((LEG-1)*25),1:"")
  1. Q
  1. ;
  1. SETKEY(DES) ;
  1. ;
  1. I DES=1 Q $$PWR^XLFMTH(2,11)
  1. I DES="2A" Q $$PWR^XLFMTH(2,10)
  1. I DES="2B" Q $$PWR^XLFMTH(2,9)
  1. I DES="3A" Q $$PWR^XLFMTH(2,8)
  1. I DES="3B" Q $$PWR^XLFMTH(2,7)
  1. I DES="4A" Q $$PWR^XLFMTH(2,6)
  1. I DES="4B" Q $$PWR^XLFMTH(2,5)
  1. I DES="5" Q $$PWR^XLFMTH(2,4)
  1. I DES="6A" Q $$PWR^XLFMTH(2,3)
  1. I DES="6B" Q $$PWR^XLFMTH(2,2)
  1. I DES="6C" Q $$PWR^XLFMTH(2,1)
  1. I DES="7" Q $$PWR^XLFMTH(2,0)
  1. Q
  1. ;
  1. SUMKEY(KEY) ;
  1. N QN,SUM
  1. S SUM=0,QN=0
  1. I '$D(KEY) Q SUM
  1. F S QN=$O(KEY(QN)) Q:'QN S SUM=SUM+KEY(QN)
  1. Q SUM
  1. MCALC(SC,KEYSUM,ROU,MCS,PCS) ;
  1. N I,MROW,PROW,MLABEL,PLABEL
  1. S MLABEL=KEYSUM_U_ROU("MKS")
  1. S MROW=$P($T(@MLABEL),";;",2,99)
  1. S PLABEL=KEYSUM_U_ROU("PKS")
  1. S PROW=$P($T(@PLABEL),";;",2,99)
  1. F I=1:1:12 D
  1. .S MCS=MCS+($P(MROW,"~",I)*SC(I))
  1. .S PCS=PCS+($P(PROW,"~",I)*SC(I))
  1. S MCS=MCS+$P(MROW,"~",13)
  1. S PCS=PCS+$P(PROW,"~",13)
  1. Q
  1. GETROU(KEYSUM,ROU) ; get routine to look up values to use in calculations
  1. N I,K1,K2,TMP
  1. K ROU
  1. S K1=""
  1. F I="MKS","PKS" F S K1=$O(@I@(K1)) Q:K1="" S K2="" D
  1. .F S K2=$O(@I@(K1,K2)) Q:'K2 D
  1. ..I KEYSUM=K1 S ROU(I)=@I@(K1,K2)
  1. ..I (KEYSUM>K1)&((KEYSUM<K2)!(KEYSUM=K2)) S ROU(I)=@I@(K1,K2)
  1. Q
  1. DATA1 ;
  1. N I,KEY,KEYSUM,VN,MTCH,ROU,SC
  1. S YSINSNAM=$P($G(YSDATA(2)),U,3)
  1. I $G(YSINSNAM)="" S YSINSNAM=$G(YS("CODE"),"NO NAME PASSED")
  1. S NODE=2 F S NODE=$O(YSDATA(NODE)) Q:NODE="" D ; Start at YSDATA(3)
  1. .S DATA=YSDATA(NODE)
  1. .S YSQN=$P(DATA,U,1)
  1. .S YSSEQ=$P(DATA,U,2),YSSEQ=$P(YSSEQ,";",1) ; Sequence Number
  1. .S YSCDA=$P($G(DATA),U,3) ; Choice ID
  1. .I (YSCDA=1155)!(YSCDA=1156)!(YSCDA="NOT ASKED") S YSCDA=""
  1. .D DESGNTR^YTSCORE(YSQN,.DES)
  1. .S LEG=$S(YSCDA'="":$$GET1^DIQ(601.75,YSCDA_",",4,"I"),1:"")
  1. .;Questions 8 and 9 are not scored
  1. .I DES<8 D
  1. ..;convert DES to Variable Name
  1. ..;S VN=$S(DES=1:"gh1x",DES="2A":"pf02x",DES="2B":"pf04x",DES="3A":"rp2x",DES="3B":"rp3x",DES="4A":"re2x",DES="4B":"re3x",DES="5":"bp2x",DES="6A":"mh3x",DES="6B":"vt2x",DES="6C":"mh4x",DES="7":"sf2x",1:"unk")
  1. ..;rather than use Var Names, use piece in row found in table routines
  1. ..S VN=$S(DES=1:1,DES="2A":2,DES="2B":3,DES="3A":4,DES="3B":5,DES="4A":6,DES="4B":7,DES="5":8,DES="6A":9,DES="6B":10,DES="6C":11,DES="7":12,1:"unk")
  1. ..S SC(VN)=$$SETSC(DES,LEG)
  1. ..I LEG="" S KEY(DES)=$$SETKEY(DES)
  1. S KEYSUM=$$SUMKEY(.KEY)
  1. I $G(KEYSUM)'="" D GETROU(.KEYSUM,.ROU)
  1. D MCALC(.SC,.KEYSUM,.ROU,.MCS,.PCS)
  1. Q
  1. ;
  1. SCORESV ;
  1. I $D(^TMP($J,"YSG",1)),^TMP($J,"YSG",1)="[ERROR]" D Q ;-->out
  1. .K ^TMP($J,"YSCOR")
  1. .S ^TMP($J,"YSCOR",1)="[ERROR]"
  1. .S ^TMP($J,"YSCOR",2)="VR-12 Scale not found"
  1. ;
  1. S PCS=$J(PCS,0,4)
  1. S MCS=$J(MCS,0,4)
  1. ;
  1. K ^TMP($J,"YSCOR")
  1. S ^TMP($J,"YSCOR",1)="[DATA]"
  1. S ^TMP($J,"YSCOR",2)=$$GET1^DIQ(601.87,627_",",3,"I")_"="_PCS
  1. S ^TMP($J,"YSCOR",3)=$$GET1^DIQ(601.87,628_",",3,"I")_"="_MCS
  1. Q
  1. ;
  1. BLDLKU ;
  1. N I,ROU,SCR,X
  1. F I=1:1 S X=$P($T(MCSKEY+I),";;",2,99) Q:X="zzzzz" D
  1. .S SCR=$P(X,"~"),ROU=$P(X,"~",2)
  1. .S MKS($P(SCR,U),$P(SCR,U,2))=ROU
  1. F I=1:1 S X=$P($T(PCSKEY+I),";;",2,99) Q:X="zzzzz" D
  1. .S SCR=$P(X,"~"),ROU=$P(X,"~",2)
  1. .S PKS($P(SCR,U),$P(SCR,U,2))=ROU
  1. Q
  1. DLLSTR(YSDATA,YS,YSTRNG) ;
  1. ; YSTRNG = 1 Score Instrument
  1. ; YSTRNG = 2 get Report Answers and Text
  1. ;
  1. N DATA,DES,NODE,LEG,YSCDA,YSAN,YSSEQ,YSQN,YSINSNAM
  1. N PCS,MCS,MKS,PKS
  1. ;
  1. S PCS=0,MCS=0
  1. ;
  1. ;Can use stored scores, all special text is in MH REPORTS
  1. I YSTRNG=2 Q
  1. ;
  1. D BLDLKU
  1. D DATA1
  1. D SCORESV
  1. Q
  1. ;
  1. MCSKEY ;
  1. ;;0^105~YTSVRM1
  1. ;;106^229~YTSVRM2
  1. ;;230^354~YTSVRM3
  1. ;;355^489~YTSVRM4
  1. ;;490^618~YTSVRM5
  1. ;;620^759~YTSVRM6
  1. ;;760^900~YTSVRM7
  1. ;;901^1046~YTSVRM8
  1. ;;1047^1174~YTSVRM9
  1. ;;1175^1312~YTSVRM10
  1. ;;1313^1454~YTSVRM11
  1. ;;1455^1600~YTSVRM12
  1. ;;1601^1745~YTSVRM13
  1. ;;1746^1898~YTSVRM14
  1. ;;1900^2063~YTSVRM15
  1. ;;2064^2190~YTSVRM16
  1. ;;2191^2327~YTSVRM17
  1. ;;2328^2467~YTSVRM18
  1. ;;2468^2612~YTSVRM19
  1. ;;2613^2756~YTSVRM20
  1. ;;2757^2907~YTSVRM21
  1. ;;2908^3074~YTSVRM22
  1. ;;3075^3210~YTSVRM23
  1. ;;3211^3359~YTSVRM24
  1. ;;3360^3514~YTSVRM25
  1. ;;3515^3671~YTSVRM26
  1. ;;3672^3829~YTSVRM27
  1. ;;3830^3989~YTSVRM28
  1. ;;3990^4094~YTSVRM29
  1. ;;zzzzz
  1. Q
  1. PCSKEY ;
  1. ;;0^112~YTSVRP1
  1. ;;113^234~YTSVRP2
  1. ;;235^359~YTSVRP3
  1. ;;360^494~YTSVRP4
  1. ;;495^620~YTSVRP5
  1. ;;621^755~YTSVRP6
  1. ;;756^893~YTSVRP7
  1. ;;894^1037~YTSVRP8
  1. ;;1038^1162~YTSVRP9
  1. ;;1163^1296~YTSVRP10
  1. ;;1297^1432~YTSVRP11
  1. ;;1433^1576~YTSVRP12
  1. ;;1577^1715~YTSVRP13
  1. ;;1716^1863~YTSVRP14
  1. ;;1864^2023~YTSVRP15
  1. ;;2024^2153~YTSVRP16
  1. ;;2154^2286~YTSVRP17
  1. ;;2287^2422~YTSVRP18
  1. ;;2423^2569~YTSVRP19
  1. ;;2570^2704~YTSVRP20
  1. ;;2705^2851~YTSVRP21
  1. ;;2852^3006~YTSVRP22
  1. ;;3007^3152~YTSVRP23
  1. ;;3153^3296~YTSVRP24
  1. ;;3297^3445~YTSVRP25
  1. ;;3446^3604~YTSVRP26
  1. ;;3605^3754~YTSVRP27
  1. ;;3755^3909~YTSVRP28
  1. ;;3910^4090~YTSVRP29
  1. ;;zzzzz
  1. Q