- 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 Jan 18, 2025@03:19:38 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