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