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

YSASOL.m

Go to the documentation of this file. 
  1. YSASOL ;ASF/ALB,HIOFO/FT - ASI ON-LINE ENTRY ;1/31/13  10:49am
  1.  ;;5.01;MENTAL HEALTH;**24,30,32,38,121**;Dec 30, 1994;Build 61
  1.  ;Reference to ^VA(200, supported by DBIA #10060
  1.  ;Reference to VADPT supported by IA #10061
  1. MAIN(YSASPIEN,YSASSIEN) ;
  1.  Q:$G(YSASSIEN)'>0
  1.  Q:$G(YSASPIEN)'>0
  1.  D SCREENH^YSASA2
  1.  S YSASLL="",$P(YSASLL,"_",79)="" ;ASF 5/22
  1.  S YSIENS=YSASSIEN_","
  1.  S YSASTYP=$$GET1^DIQ(604,YSIENS,"CLASS")
  1.  S YSGP=$S(YSASTYP?1"L".E:5,YSASTYP?1"FO".E:6,1:4)
  1.  S DFN=YSASPIEN D DEM^VADPT S YSHDR1=VADM(1)_"   "_"xxx-xx-"_$E($P(VADM(2),U,2),8,11) D KVAR^VADPT
  1.  S YSFILE=604,YSFLAG="EF",YSBACK=1 ;ASF 5/16
  1.  S YSFDA="^TMP($J,""YSASI"")"
  1.  K ^TMP($J,"YSASI")
  1.  S YSDFLAG=$$GET1^DIQ(604.8,"1,",.04)
  1.  S YSEFLAG=$$GET1^DIQ(604.8,"1,",.07)
  1.  S YSN=0,YSV=""
  1. LOOP ;
  1.  F  S YSN=$O(^YSTX(604.66,YSN)) Q:YSN'>0!(YSV="^")  S YSENDLP=0 D L3
  1.   D HEAD
  1.  D FILE^DIE("K","^TMP($J,""YSASI"")")
  1. WP ;
  1.  K DIRUT,DIR F  Q:$D(DIRUT)  D
  1.  . W !!?10,"*** Additional Areas ***",!,"1. Spiritual",!,"2. Leisure",!
  1.  . S DIR("A")="Enter Comment for? ",DIR(0)="SAO^1:Spiritual;2:Leisure" D ^DIR
  1.  . Q:$D(DIRUT)
  1.  . S DR=$S(Y=1:188,Y=2:187,1:"")
  1.  . S DA=YSASSIEN,DIE="^YSTX(604,"
  1.  . D ^DIE
  1.  . Q
  1.  ;
  1.  D EN^YSASSN(YSASSIEN)
  1.  Q
  1. L3 ;
  1.  S YSG=^YSTX(604.66,YSN,0),YSFIELD=+$P(YSG,U,3),YSQ=$P(YSG,U,2),YSDEF=$P(YSG,U,7),YSASENT=$P(YSG,U,9),YSASID=$P(YSG,U,11)
  1.  S YSASEX=$G(^YSTX(604.66,YSN,1))
  1.  Q:$P(YSG,U,YSGP)=""
  1.  ;
  1.  Q:YSENDLP  ;quit if executable sets flag
  1.  ;
  1. L4 ;No form feed
  1.  D FDAGET S YSP=Y
  1.  S:YSP=""!(YSP="^") YSP=$$GET1^DIQ(604,YSIENS,YSFIELD)
  1.  I YSP="",YSDFLAG="YES" S YSP=YSDEF ; SET DEFAULT IF FLAG SET
  1.  D DISP ;W !,YSQ,$S(YSP="":": ",1:": "_YSP_" // ")
  1. L5 R YSV:DTIME S:'$T YSV="^"
  1.  S:YSV="" YSV=YSP
  1.  Q:YSV=""!(YSV="^")
  1.  I YSV?1"^"1A1N.E D  Q:YSNN1'=0
  1.  . I YSV?1"^"1L.N S YSV="^"_$C($A(YSV,2)-32)_$E(YSV,3,9)
  1.  . S (YSNN,YSNN1)=0,YSBACK=YSN-.01 ;ASF 5/16
  1.  . S YSNN=$O(^YSTX(604.66,"C",$E(YSV,2,9)))
  1.  . Q:$E(YSNN,1,$L(YSV)-1)'=$E(YSV,2,9)
  1.  . S:$L(YSNN) YSNN1=$O(^YSTX(604.66,"C",YSNN,-1))
  1.  . S:YSNN1 YSN=YSNN1-.01
  1.  ;
  1.  I YSV="^b"!(YSV="^B") S:$D(YSBACK) YSN=YSBACK Q  ;ASF 5/16
  1.  I YSV="?" D DISPQ G L4
  1.  I YSV?1"??"."?" D  G L5
  1.  .I YSFIELD'=.09,YSFIELD'=2,YSFIELD'=9.14,YSFIELD'=10.45,YSFIELD'=14.26,YSFIELD'=14.28 W $C(7)," No extended help available " Q
  1.  . I YSFIELD=2 D HEAD D  D ANS
  1.  .. S DIC="^YSTX(604.26,",DIC(0)="FIS",D="B",DZ="??" D DQ^DICQ K DIC,DIE,DID,D,DIX,DO
  1.  . I YSFIELD=10.45 D HEAD D  D ANS
  1.  .. S DIC="^YSTX(604.77,",DIC(0)="FIS",D="B",DZ="??" D DQ^DICQ K DIC,DIE,DID,D,DIX,DO
  1.  . I YSFIELD=14.26!(YSFIELD=14.28) D HEAD D  D ANS
  1.  .. S DIC="^YSTX(604.3,",DIC(0)="FIS",D="B",DZ="??" D DQ^DICQ K DIC,DIE,DID,D,DIX,DO
  1.  . I YSFIELD=9.14 D HEAD D  D ANS
  1.  .. S Y=0 F  S Y=$O(^YSTX(604.68,3,1,Y)) Q:Y'>0  W !,^(Y,0)
  1.  . I YSFIELD=.09 D HEAD D
  1.  .. S DIC="^VA(200,",DIC(0)="AEQM",DIC("A")="Select Interviewer: "
  1.  .. D ^DIC S YSP=$S(+Y>0:$P(Y,U,2),1:"????") K DIC D ANS ;ASF 5/16
  1.  . Q
  1.  I YSV?1"^C".E!(YSV?1"^c".E) D  G L4
  1.  . S DIE="^YSTX(604,",DA=YSASSIEN
  1.  . S DR=$S(YSASID?1"G".E:.6,YSASID?1"M".E:8.5,YSASID?1"E".E:9.5,YSASID?1"D".E:10.5,YSASID?1"L".E:14.5,YSASID?1"H".E:16.5,YSASID?1"F".E:18.5,YSASID?1"P".E:19.5,1:"")
  1.  . I DR D
  1.  .. D HEAD
  1.  . D ^DIE
  1.  ;
  1.  S:YSV?1N.N YSV=+YSV ;ASF 5/16/97
  1.  D VAL
  1.  I YSA="^" W $C(7),"?? " G L5
  1.  W ?$X+3,YSA(0)
  1.  I YSEFLAG="YES" X YSASEX ; branch if parameters allowed
  1.  Q
  1. VAL ;
  1.  D VAL^DIE(YSFILE,YSIENS,YSFIELD,YSFLAG,YSV,.YSA,YSFDA,"^TMP($J,""YSASERR"")")
  1.  Q
  1. TEST ;
  1.  D MAIN(1,30)
  1.  Q
  1. FDAGET ;
  1.  S Y=$$VALUE1^DILF(YSFILE,YSFIELD,YSFDA)
  1.  S:Y'=""&(Y'="^") Y=$$EXTERNAL^DILFD(YSFILE,YSFIELD,"",Y)
  1.  Q
  1. DISP ;display question
  1.  D HEAD
  1.  W ?15,YSASRV1,YSASID,YSASRV0,"  "
  1.  W $S(YSASID?1"G".E:"General Information",YSASID?1"M".E:"Medical Status",YSASID?1"E".E:"Employment Status",YSASID?1"D".E:"Drug/Alcohol Status",YSASID?1"L".E:"Legal Status",1:"")
  1.  W $S(YSASID?1"P".E:"Psychiatric Status",YSASID?1"H".E:"Family History",YSASID?1"F".E:"Family/Social Relationships",1:"")
  1. HINT ;
  1.  S DX=0,DY=20 X IOXY W YSASLL ;ASF 5/22
  1.  W !,$G(^YSTX(604.66,YSN,3,1,0)),!,$G(^YSTX(604.66,YSN,3,2,0))
  1.  W !,$E($G(^YSTX(604.66,YSN,3,3,0)),1,50),?62,YSASRV1,"Enter ? for help",YSASRV0
  1.  S DX=0,DY=3 X IOXY
  1.  W YSASRV1 S J=0 F  S J=$O(^YSTX(604.66,YSN,2,J)) Q:J'>0  W !,$S(J=1&($P(^YSTX(604.66,YSN,0),U,10)=1)&(YSASTYP="FOLLOWUP"):"* ",1:""),^YSTX(604.66,YSN,2,J,0)
  1.  W YSASRV0
  1.  I YSFIELD>3,YSFIELD'=10.45,YSFIELD'=14.26,YSFIELD'=14.28,$P(^DD(604,YSFIELD,0),U,2)?.E1"P".E D
  1.  . S YSATRIB=$P(^DD(604,YSFIELD,0),U,3) ;$$GET1^DID(YSFILE,YSFIELD,"","POINTER")
  1.  . S DIC="^"_YSATRIB,DIC(0)="FIS",D="B",DZ="??" D DQ^DICQ K DIC,DIE,DID,D,DIX,DO
  1.  E  I YSFIELD'=9.14 W ! D HELP^DIE(604,"",YSFIELD,"?"),MSG^DIALOG("HW") W !
  1.  I YSFIELD=9.14 W !!!,^DD(604,YSFIELD,3),!
  1.  ;
  1. ANS W:$Y<10 !
  1.  W !,YSASID_" Answer",$S(YSP="":": ",1:": "_YSP_" // ")
  1.  Q 
  1. DISPQ ;
  1.  D HEAD
  1.  D EN^DDIOL("","^YSTX(604.68,21,1)")
  1.  S DX=0,DY=22 X IOXY K DIR S DIR(0)="E" D ^DIR
  1.  Q
  1.  W @IOF,IOHOME,IOEDEOP
  1.  W YSHDR1,?45,"Addiction Severity Index ",YSASRV1,YSASTYP,YSASRV0,!
  1.  W YSASLL,! ;ASF 5/22
  1.  Q