YSASO2 ;692/DCL-ASI/ASF COMPOSITE SCORES FOR LITE ;5/22/97 11:10
;;5.01;MENTAL HEALTH;**24,30**;Dec 30, 1994
Q
OUT3(YSASIEN,YSASOK) ;Entry Point pass IEN from file 604 FOR LITE
Q:$G(YSASIEN)'>0
N YSASY,YSASSR,YSASCS,YSASN,YSASAGE,X,Y,C1,C2,C3,YSASS,YSASC,YSASMSG
S YSASIEN=YSASIEN_",",C1=24,C2=40,C3=55,YSASOK=1,YSASMSG=""
S YSASN=$$F("NAME"),YSASAGE=$$F("NAME:AGE"),YSASNA=YSASN_" ("_YSASAGE_")"
W:$D(IOF) @IOF
W !,YSASNA,?C2,"Composite"
W !,$TR($J("",$L(YSASNA))," ","-"),?C2,"Scores"
W !," Adm: ",$$F(1),?C2,"--------"
S YSASC=$$F(.61)
W !," Int: ",$$F(.05),?C1," MEDICAL",?C2,$S(YSASC="":" ----",1:YSASC)
S YSASC=$$F(.62)
S X=$$F(.09)
W !," By: ",$S(X]"":$P(X,","),1:"<INCOMPLETE>"),?C1," EMPLOYMENT",?C2,$S(YSASC="":" ----",1:YSASC)
S YSASC=$$F(.63)
W !?C1," ALCOHOL",?C2,$S(YSASC="":" ----",1:YSASC)
S YSASC=$$F(.635)
W !?C1," DRUG",?C2,$S(YSASC="":" ----",1:YSASC)
S YSASC=$$F(.64)
W !?C1," LEGAL",?C2,$S(YSASC="":" ----",1:YSASC)
S YSASC=$$F(.65)
W !?C1," FAMILY",?C2,$S(YSASC="":" ----",1:YSASC)
S YSASC=$$F(.66)
W !?C1,"PSYCHIATRIC",?C2,$S(YSASC="":" ----",1:YSASC)
Q
;
F(YSASFLD) ;Pass field name - IEN is expected to be in YSASIEN
N DIERR
Q:$G(YSASFLD)=""
Q $$GET1^DIQ(604,YSASIEN,YSASFLD)
;
CHECKALL(YSASIEN,YSFLAG) ; all reqiured fields
;ysflag 1= ok 0= missing 2= X OR N
N N1,YSASCLS,X,YSASFLD,YSF
S YSFLAG=1
S YSASCLS=$$GET1^DIQ(604,YSASIEN_",",.04,"I")
S YSASCLS=YSASCLS+3
S N1=0 F S N1=$O(^YSTX(604.66,N1)) Q:N1'>0 D:($P(^YSTX(604.66,N1,0),U,8)&($P(^YSTX(604.66,N1,0),U,YSASCLS))) Q:YSFLAG=0
. S YSASFLD=$P(^YSTX(604.66,N1,0),U,3)
. S YSF=$S(YSASFLD>10.02&(YSASFLD<10.44):"I",$P(^DD(604,YSASFLD,0),U,2)?1"P".E:"",1:"I")
. S X=$$GET1^DIQ(604,YSASIEN,YSASFLD,YSF)
. S:X="" YSFLAG=0
. S:X="X"!(X="N") YSFLAG=2
;
Q
TESTIT ;
S YSASIEN=72 D CHECKALL(YSASIEN,.YSFLAG)
W !,"YSFLAG=",YSFLAG D:YSFLAG'=1 REPTMSG(YSASIEN)
Q
Q
REPTMSG(YSASIEN) ;report missing requires
N N1,X,YSASFLD,YSASCLS,YSF
S YSASDT=$$GET1^DIQ(604,YSASIEN_",",.05)
S YSASPT=$$GET1^DIQ(604,YSASIEN_",",.02)
S YSASCLS=$$GET1^DIQ(604,YSASIEN_",",.04,"I")
S YSASCLS=YSASCLS+3
W @IOF,YSASPT," interviewed on ",YSASDT,!,"Required ASI Items M=missing, X= not answered, N= not applicable",!
S N1=0 F S N1=$O(^YSTX(604.66,N1)) Q:N1'>0 D:($P(^YSTX(604.66,N1,0),U,8)&($P(^YSTX(604.66,N1,0),U,YSASCLS)))
. S YSASFLD=$P(^YSTX(604.66,N1,0),U,3)
. S YSF=$S(YSASFLD>10.02&(YSASFLD<10.44):"I",$P(^DD(604,YSASFLD,0),U,2)?1"P".E:"",1:"I")
. S X=$$GET1^DIQ(604,YSASIEN,YSASFLD,YSF)
. D:X=""!(X="N")!(X="X")
.. W:$X>60 !
.. W $J($P(^YSTX(604.66,N1,0),U,11)_":"_$S(X="":"M",1:X),10)
;
W ! K DIR S DIR(0)="E" D ^DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSASO2 2747 printed Sep 23, 2025@19:49:19 Page 2
YSASO2 ;692/DCL-ASI/ASF COMPOSITE SCORES FOR LITE ;5/22/97 11:10
+1 ;;5.01;MENTAL HEALTH;**24,30**;Dec 30, 1994
+2 QUIT
OUT3(YSASIEN,YSASOK) ;Entry Point pass IEN from file 604 FOR LITE
+1 if $GET(YSASIEN)'>0
QUIT
+2 NEW YSASY,YSASSR,YSASCS,YSASN,YSASAGE,X,Y,C1,C2,C3,YSASS,YSASC,YSASMSG
+3 SET YSASIEN=YSASIEN_","
SET C1=24
SET C2=40
SET C3=55
SET YSASOK=1
SET YSASMSG=""
+4 SET YSASN=$$F("NAME")
SET YSASAGE=$$F("NAME:AGE")
SET YSASNA=YSASN_" ("_YSASAGE_")"
+5 if $DATA(IOF)
WRITE @IOF
+6 WRITE !,YSASNA,?C2,"Composite"
+7 WRITE !,$TRANSLATE($JUSTIFY("",$LENGTH(YSASNA))," ","-"),?C2,"Scores"
+8 WRITE !," Adm: ",$$F(1),?C2,"--------"
+9 SET YSASC=$$F(.61)
+10 WRITE !," Int: ",$$F(.05),?C1," MEDICAL",?C2,$SELECT(YSASC="":" ----",1:YSASC)
+11 SET YSASC=$$F(.62)
+12 SET X=$$F(.09)
+13 WRITE !," By: ",$SELECT(X]"":$PIECE(X,","),1:"<INCOMPLETE>"),?C1," EMPLOYMENT",?C2,$SELECT(YSASC="":" ----",1:YSASC)
+14 SET YSASC=$$F(.63)
+15 WRITE !?C1," ALCOHOL",?C2,$SELECT(YSASC="":" ----",1:YSASC)
+16 SET YSASC=$$F(.635)
+17 WRITE !?C1," DRUG",?C2,$SELECT(YSASC="":" ----",1:YSASC)
+18 SET YSASC=$$F(.64)
+19 WRITE !?C1," LEGAL",?C2,$SELECT(YSASC="":" ----",1:YSASC)
+20 SET YSASC=$$F(.65)
+21 WRITE !?C1," FAMILY",?C2,$SELECT(YSASC="":" ----",1:YSASC)
+22 SET YSASC=$$F(.66)
+23 WRITE !?C1,"PSYCHIATRIC",?C2,$SELECT(YSASC="":" ----",1:YSASC)
+24 QUIT
+25 ;
F(YSASFLD) ;Pass field name - IEN is expected to be in YSASIEN
+1 NEW DIERR
+2 if $GET(YSASFLD)=""
QUIT
+3 QUIT $$GET1^DIQ(604,YSASIEN,YSASFLD)
+4 ;
CHECKALL(YSASIEN,YSFLAG) ; all reqiured fields
+1 ;ysflag 1= ok 0= missing 2= X OR N
+2 NEW N1,YSASCLS,X,YSASFLD,YSF
+3 SET YSFLAG=1
+4 SET YSASCLS=$$GET1^DIQ(604,YSASIEN_",",.04,"I")
+5 SET YSASCLS=YSASCLS+3
+6 SET N1=0
FOR
SET N1=$ORDER(^YSTX(604.66,N1))
if N1'>0
QUIT
if ($PIECE(^YSTX(604.66,N1,0),U,8)&($PIECE(^YSTX(604.66,N1,0),U,YSASCLS)))
Begin DoDot:1
+7 SET YSASFLD=$PIECE(^YSTX(604.66,N1,0),U,3)
+8 SET YSF=$SELECT(YSASFLD>10.02&(YSASFLD<10.44):"I",$PIECE(^DD(604,YSASFLD,0),U,2)?1"P".E:"",1:"I")
+9 SET X=$$GET1^DIQ(604,YSASIEN,YSASFLD,YSF)
+10 if X=""
SET YSFLAG=0
+11 if X="X"!(X="N")
SET YSFLAG=2
End DoDot:1
if YSFLAG=0
QUIT
+12 ;
+13 QUIT
TESTIT ;
+1 SET YSASIEN=72
DO CHECKALL(YSASIEN,.YSFLAG)
+2 WRITE !,"YSFLAG=",YSFLAG
if YSFLAG'=1
DO REPTMSG(YSASIEN)
+3 QUIT
+4 QUIT
REPTMSG(YSASIEN) ;report missing requires
+1 NEW N1,X,YSASFLD,YSASCLS,YSF
+2 SET YSASDT=$$GET1^DIQ(604,YSASIEN_",",.05)
+3 SET YSASPT=$$GET1^DIQ(604,YSASIEN_",",.02)
+4 SET YSASCLS=$$GET1^DIQ(604,YSASIEN_",",.04,"I")
+5 SET YSASCLS=YSASCLS+3
+6 WRITE @IOF,YSASPT," interviewed on ",YSASDT,!,"Required ASI Items M=missing, X= not answered, N= not applicable",!
+7 SET N1=0
FOR
SET N1=$ORDER(^YSTX(604.66,N1))
if N1'>0
QUIT
if ($PIECE(^YSTX(604.66,N1,0),U,8)&($PIECE(^YSTX(604.66,N1,0),U,YSASCLS)))
Begin DoDot:1
+8 SET YSASFLD=$PIECE(^YSTX(604.66,N1,0),U,3)
+9 SET YSF=$SELECT(YSASFLD>10.02&(YSASFLD<10.44):"I",$PIECE(^DD(604,YSASFLD,0),U,2)?1"P".E:"",1:"I")
+10 SET X=$$GET1^DIQ(604,YSASIEN,YSASFLD,YSF)
+11 if X=""!(X="N")!(X="X")
Begin DoDot:2
+12 if $X>60
WRITE !
+13 WRITE $JUSTIFY($PIECE(^YSTX(604.66,N1,0),U,11)_":"_$SELECT(X="":"M",1:X),10)
End DoDot:2
End DoDot:1
+14 ;
+15 WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
+16 QUIT
