YTQLIB ;ASF/ALB - MHQ LIBRARY FUNCTIONS ;Jun 26, 2024@09:53:51
;;5.01;MENTAL HEALTH;**85,252**;Dec 30, 1994;Build 3
;
;
Q
TSLIST(YSDATA) ;list tests and surveys
N YSTESTN,YSTEST,N
K YSDATA
S N=1,YSDATA(N)="[DATA]"
S YSTEST="" F S YSTEST=$O(^YTT(601.71,"B",YSTEST)) Q:YSTEST="" D
. S YSTESTN=$O(^YTT(601.71,"B",YSTEST,0))
. S N=N+1
. S YSDATA(N)=YSTESTN_U_YSTEST_U_$$GET1^DIQ(601.71,YSTESTN_",",18)
Q
;
NEW(YSFILEN) ;Adding New Entries - return an internal number - EXTRINSIC FUNCTION
;if $D YSPROG then National and pointers less than 100,000 else pointers greater than 100,000
;
; Calling application must lock file header node (^YTT(YSFILEN,0)) before calling this function,
; and needs to file the data using the returned IEN before releasing the lock.
;
N MHQ2X,YS
K YSPROG
S:$D(^XUSEC("YSPROG",DUZ)) YSPROG=1
S YS=$P($G(^YTT(YSFILEN,0)),U,3) S:YS<1 YS=1
I $D(YSPROG) S YS=$S(YS<100000:YS,1:1)
I '$D(YSPROG) S YS=$S(YS>100000:YS,1:100000)
F MHQ2X=YS:1 I '$D(^YTT(YSFILEN,MHQ2X)) QUIT
Q MHQ2X
;
ADMCK(YSDATA,YS) ;check administration
N G,K,YSA,YSAD,YSCANS,YSCOMP,YSCTREF,YSDFN,YSDG,YSDS,YSIEN,YSINS,YSK,YSQN
S N=1
S YSDATA(1)="[ERROR]"
S YSAD=$G(YS("AD"))
I YSAD'?1N.N S YSDATA(2)="bad admin #" D SAY Q ;-->out
I '$D(^YTT(601.84,YSAD,0)) S YSDATA(2)="bad admin ref" D SAY Q ;-->out
S G=^YTT(601.84,YSAD,0)
S YSDFN=$P(G,U,2) I '$D(^DPT(YSDFN,0)) S YSDATA(2)="bad pt ref" D SAY Q ;-->out
S YSINS=$P(G,U,3) I '$D(^YTT(601.71,YSINS)) S YSDATA(2)="test not found" D SAY Q ;-->out
S YSDG=$P(G,U,4) I YSDG'?7N.NP S YSDATA(2)="date given bad" D SAY Q ;-->out
S YSDS=$P(G,U,5) I YSDG'?7N.NP S YSDATA(2)="date SAVED bad" D SAY Q ;-->out
S YSCOMP=$P(G,U,9)
S YSDATA(1)="[DATA]"
I YSCOMP'="Y" S YSDATA(2)="incomplete" D SAY Q ;-->out
D SAY
;loop thru answers to this admin
S YSQN=0,YSDATA(1)="[ERROR]"
F S YSQN=$O(^YTT(601.85,"AC",YSAD,YSQN)) Q:YSQN'>0 S YSIEN=0 F S YSIEN=$O(^YTT(601.85,"AC",YSAD,YSQN,YSIEN)) Q:YSIEN'>0 D
. S YSA=$G(^YTT(601.85,YSIEN,0)),YSCANS=$P(YSA,U,4)
. I '$D(^YTT(601.76,"AF",YSINS,YSQN)) S YSDATA(2)="question not in battery" D SAYQ Q ;-->out
. S YSCTREF=$P(^YTT(601.72,YSQN,2),U,3)
. S K=0,YSK=0
. I YSCANS?1N.N F S K=$O(^YTT(601.751,"ACT",YSCANS,K)) Q:(YSK)!(K'>0) I $P(^YTT(601.751,K,0),U,1)=YSCTREF S YSK=1
. I YSK=0 S YSDATA(2)="bad choice" D SAYQ Q
. S YSDATA(1)="[DATA]" K YSDATA(2) D SAYQ
Q
SAY W !,N," ",YSAD," ",YSDATA(1)," ",$G(YSDATA(2)) Q
SAYQ W !?10,$G(YSDATA(1))," ",YSAD," ",YSQN," ",YSA," ctype: ",YSCTREF," Cans: ",YSCANS Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQLIB 2597 printed Dec 13, 2024@02:18:31 Page 2
YTQLIB ;ASF/ALB - MHQ LIBRARY FUNCTIONS ;Jun 26, 2024@09:53:51
+1 ;;5.01;MENTAL HEALTH;**85,252**;Dec 30, 1994;Build 3
+2 ;
+3 ;
+4 QUIT
TSLIST(YSDATA) ;list tests and surveys
+1 NEW YSTESTN,YSTEST,N
+2 KILL YSDATA
+3 SET N=1
SET YSDATA(N)="[DATA]"
+4 SET YSTEST=""
FOR
SET YSTEST=$ORDER(^YTT(601.71,"B",YSTEST))
if YSTEST=""
QUIT
Begin DoDot:1
+5 SET YSTESTN=$ORDER(^YTT(601.71,"B",YSTEST,0))
+6 SET N=N+1
+7 SET YSDATA(N)=YSTESTN_U_YSTEST_U_$$GET1^DIQ(601.71,YSTESTN_",",18)
End DoDot:1
+8 QUIT
+9 ;
NEW(YSFILEN) ;Adding New Entries - return an internal number - EXTRINSIC FUNCTION
+1 ;if $D YSPROG then National and pointers less than 100,000 else pointers greater than 100,000
+2 ;
+3 ; Calling application must lock file header node (^YTT(YSFILEN,0)) before calling this function,
+4 ; and needs to file the data using the returned IEN before releasing the lock.
+5 ;
+6 NEW MHQ2X,YS
+7 KILL YSPROG
+8 if $DATA(^XUSEC("YSPROG",DUZ))
SET YSPROG=1
+9 SET YS=$PIECE($GET(^YTT(YSFILEN,0)),U,3)
if YS<1
SET YS=1
+10 IF $DATA(YSPROG)
SET YS=$SELECT(YS<100000:YS,1:1)
+11 IF '$DATA(YSPROG)
SET YS=$SELECT(YS>100000:YS,1:100000)
+12 FOR MHQ2X=YS:1
IF '$DATA(^YTT(YSFILEN,MHQ2X))
QUIT
+13 QUIT MHQ2X
+14 ;
ADMCK(YSDATA,YS) ;check administration
+1 NEW G,K,YSA,YSAD,YSCANS,YSCOMP,YSCTREF,YSDFN,YSDG,YSDS,YSIEN,YSINS,YSK,YSQN
+2 SET N=1
+3 SET YSDATA(1)="[ERROR]"
+4 SET YSAD=$GET(YS("AD"))
+5 ;-->out
IF YSAD'?1N.N
SET YSDATA(2)="bad admin #"
DO SAY
QUIT
+6 ;-->out
IF '$DATA(^YTT(601.84,YSAD,0))
SET YSDATA(2)="bad admin ref"
DO SAY
QUIT
+7 SET G=^YTT(601.84,YSAD,0)
+8 ;-->out
SET YSDFN=$PIECE(G,U,2)
IF '$DATA(^DPT(YSDFN,0))
SET YSDATA(2)="bad pt ref"
DO SAY
QUIT
+9 ;-->out
SET YSINS=$PIECE(G,U,3)
IF '$DATA(^YTT(601.71,YSINS))
SET YSDATA(2)="test not found"
DO SAY
QUIT
+10 ;-->out
SET YSDG=$PIECE(G,U,4)
IF YSDG'?7N.NP
SET YSDATA(2)="date given bad"
DO SAY
QUIT
+11 ;-->out
SET YSDS=$PIECE(G,U,5)
IF YSDG'?7N.NP
SET YSDATA(2)="date SAVED bad"
DO SAY
QUIT
+12 SET YSCOMP=$PIECE(G,U,9)
+13 SET YSDATA(1)="[DATA]"
+14 ;-->out
IF YSCOMP'="Y"
SET YSDATA(2)="incomplete"
DO SAY
QUIT
+15 DO SAY
+16 ;loop thru answers to this admin
+17 SET YSQN=0
SET YSDATA(1)="[ERROR]"
+18 FOR
SET YSQN=$ORDER(^YTT(601.85,"AC",YSAD,YSQN))
if YSQN'>0
QUIT
SET YSIEN=0
FOR
SET YSIEN=$ORDER(^YTT(601.85,"AC",YSAD,YSQN,YSIEN))
if YSIEN'>0
QUIT
Begin DoDot:1
+19 SET YSA=$GET(^YTT(601.85,YSIEN,0))
SET YSCANS=$PIECE(YSA,U,4)
+20 ;-->out
IF '$DATA(^YTT(601.76,"AF",YSINS,YSQN))
SET YSDATA(2)="question not in battery"
DO SAYQ
QUIT
+21 SET YSCTREF=$PIECE(^YTT(601.72,YSQN,2),U,3)
+22 SET K=0
SET YSK=0
+23 IF YSCANS?1N.N
FOR
SET K=$ORDER(^YTT(601.751,"ACT",YSCANS,K))
if (YSK)!(K'>0)
QUIT
IF $PIECE(^YTT(601.751,K,0),U,1)=YSCTREF
SET YSK=1
+24 IF YSK=0
SET YSDATA(2)="bad choice"
DO SAYQ
QUIT
+25 SET YSDATA(1)="[DATA]"
KILL YSDATA(2)
DO SAYQ
End DoDot:1
+26 QUIT
SAY WRITE !,N," ",YSAD," ",YSDATA(1)," ",$GET(YSDATA(2))
QUIT
SAYQ WRITE !?10,$GET(YSDATA(1))," ",YSAD," ",YSQN," ",YSA," ctype: ",YSCTREF," Cans: ",YSCANS
QUIT
