source: FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSASA2.m@ 1397

YSASA2 ;ASF/ALB-ASI QUICK ENTRY ;3/19/98  15:08
 ;;5.01;MENTAL HEALTH;**24,30,32,38**;Dec 30, 1994
 Q
AA(YSASPIEN,YSASTYP) ;Add  NEW RECORD
 Q:$G(YSASPIEN)'>0
 Q:$G(YSASTYP)'>0
 N YSASGE,YSASRACE,YSASREL,YSASU0,YSASU1,YSASNEW,YSASNM
 N YSASSEX,YSASG0,YSASG1,YSASHL,YSASI0,YSASI1,YSASLT,YSASVL,YSASTT,YSASTRC
 N YSASBLC,YSASTLC,YSASTRC,YSASDFLT
 N YSASBT,YSASBRC
 N YSASN  ;age and name
 N IOHG,IOINHI,IOINORM,IOUOFF,IOUON
 N DIC,DA,X,Y,DDSFILE,DR,DLAYGO,DIERR
 S Y=YSASPIEN,Y(0)=^DPT(Y,0)
 W !!,"...reading Patient information..."
 S YSASRACE=$$RACE^YSASLIB($P(Y(0),"^",6)),YSASREL=$$REL^YSASLIB($P(Y(0),"^",8)),YSASSEX=$P(Y(0),"^",2)
 S YSASGE=$$GET1^DIQ(2,+Y_",","AGE"),YSASNM=$P(Y(0),U)
 W !,"...creating new ASI record..."
 S DLAYGO=604
 S DIC="^YSTX(604,",DIC(0)="L",X="NEW"
 D ^DIC
 Q:Y'>0
 S YSASSIEN=+Y,YSASNEW=$P(Y,"^",3)=1
 N DIE,DA,DR,X,Y,YSAS,YSASF,YSASV,YSAS033,YSASC,YSASDF,YSASLR
 S DIE=DIC,DA=YSASSIEN
 S DR=".02///`"_YSASPIEN
 S DR=DR_";.04///"_YSASTYP
 S DR=DR_";.05///NOW;.09////"_DUZ ;ASF 6/24
 S:YSASRACE]"" DR=DR_";.16///"_YSASRACE
 S:YSASREL]"" DR=DR_";.17///"_YSASREL
 D ^DIE
 ;
 Q
MAIN(YSASPIEN,YSASSIEN) ;
 Q:$G(YSASSIEN)'>0
 Q:$G(YSASPIEN)'>0
 D SCREENH
 S YSIENS=YSASSIEN_","
 S YSASTYP=$$GET1^DIQ(604,YSIENS,"CLASS")
 S YSGP=$S(YSASTYP?1"L".E:5,YSASTYP?1"FO".E:6,1:4)
 S DFN=YSASPIEN D DEM^VADPT S YSHDR1=VADM(1)_"   "_$P(VADM(2),U,2) D KVAR^VADPT
 S YSHDR2="Addiction Severity Index  "_YSASTYP
 W @IOF,YSHDR1,?45,YSASI1,YSHDR2,YSASI0,!
 S YSFILE=604,YSFLAG="EF"
 S YSFDA="^TMP($J,""YSASI"")"
 K ^TMP($J,"YSASI")
 S YSDFLAG=$$GET1^DIQ(604.8,"1,",.04)
 S YSEFLAG=$$GET1^DIQ(604.8,"1,",.07)
 S YSN=0,YSV=""
LOOP ;
 F  S YSN=$O(^YSTX(604.66,YSN)) Q:YSN'>0!(YSV="^")  S YSENDLP=0 D L3
 W !
 K DIR S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Save editing session" D ^DIR K DIR
 Q:'Y
 D FILE^DIE("K","^TMP($J,""YSASI"")")
WP ;
 K DIRUT,DIR F  Q:$D(DIRUT)  D
 . W !?10,"*** Comments ***",!,"1. General Info",?20,"2. Medical",?40,"3. Employment",?60,"4. Drug/Alcohol"
 . W !,"5. Legal",?20,"6. Family hx",?40,"7. Social",?60,"8. Psychiatric"
 . W !,"9. Spiritual",?19,"10. Leisure",!
 . K DIR S DIR("A")="Enter Comment for? ",DIR(0)="NO^1:10:0" D ^DIR
 . Q:$D(DIRUT)
 . S DR=$S(Y=1:.6,Y=2:8.5,Y=3:9.5,Y=4:10.5,Y=5:14.5,Y=6:16.5,Y=7:18.5,Y=8:19.5,Y=9:188,Y=10:187)
 . S DA=YSASSIEN,DIE="^YSTX(604,"
 . D ^DIE
 . Q
 ;
 D EN^YSASSN(YSASSIEN)
 Q
L3 ;
 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)
 S YSASEX=$G(^YSTX(604.66,YSN,1))
 Q:$P(YSG,U,YSGP)=""
 W:$Y+4>IOSL @IOF,YSHDR1,?45,YSASI1,YSHDR2,YSASI0,!
 Q:YSENDLP  ;quit if executable sets flag
 I YSASENT'="" W YSASI1 X YSASENT W YSASI0
L4 ;No form feed
 D FDAGET S YSP=Y
 S:YSP=""!(YSP="^") YSP=$$GET1^DIQ(604,YSIENS,YSFIELD)
 I YSP="",YSDFLAG="YES" S YSP=YSDEF ; SET DEFAULT IF FLAG SET
 W !,$S($P(^YSTX(604.66,YSN,0),U,10)=1&(YSASTYP="FOLLOWUP"):"* ",1:""),YSQ,$S(YSP="":": ",1:": "_YSP_" // ")
 R YSV:DTIME S:'$T YSV="^"
 S:YSV="" YSV=YSP
 Q:YSV=""!(YSV="^")
 I YSV?1"^"1A1N.E D  Q:YSNN1'=0
 . I YSV?1"^"1L.N S YSV="^"_$C($A(YSV,2)-32)_$E(YSV,3,9)
 . S (YSNN,YSNN1)=0
 . S YSNN=$O(^YSTX(604.66,"C",$E(YSV,2,9)))
 . Q:$E(YSNN,1,$L(YSV)-1)'=$E(YSV,2,9)
 . S:$L(YSNN) YSNN1=$O(^YSTX(604.66,"C",YSNN,-1))
 . S:YSNN1 YSN=YSNN1-.01
 ;
 I YSV?1"?".E W YSASI1 D  W YSASI0 K YSATRIB G L4
 . S YSATRIB=$P(^DD(604,YSFIELD,0),U,3) ;$$GET1^DID(YSFILE,YSFIELD,"","POINTER")
 . I YSATRIB?1"YSTX".E S DIC="^"_YSATRIB,DIC(0)="FIS",D="B" D DQ^DICQ K DIC,DIE,DID,D,DIX,DO
 . I YSATRIB'?1"YSTX".E D HELP^DIE(YSFILE,"",YSFIELD,"?",YSFDA),MSG^DIALOG("WH","","","",YSFDA)
 . Q
 S:YSV?1N.N YSV=+YSV ;ASF 5/16
 D VAL
 I YSA="^" W $C(7) D HELP^DIE(YSFILE,"",YSFIELD,"?",YSFDA),MSG^DIALOG("WH","","","",YSFDA) G L4
 W ?$X+3,YSA(0)
 I YSEFLAG="YES" X YSASEX ; branch if parameters allowed
 Q
VAL ;
 D VAL^DIE(YSFILE,YSIENS,YSFIELD,YSFLAG,YSV,.YSA,YSFDA,"^TMP($J,""YSASERR"")")
 Q
FDAGET ;
 S Y=$$VALUE1^DILF(YSFILE,YSFIELD,YSFDA)
 S:Y'=""&(Y'="^") Y=$$EXTERNAL^DILFD(YSFILE,YSFIELD,"",Y)
 Q
SCREENH ;
 D:'$D(IOST) HOME^%ZIS
 ;D GSET^%ZISS
 ;S YSASVL=IOG1_IOVL_IOG0,YSASLT=IOG1_IOLT_IOG0,YSASG1=IOG1,YSASG0=IOG0
 ;S YSASHL=IOHL,YSASTT=$G(IOTT),YSASTRC=IOTRC,YSASBT=$G(IOBT),YSASBRC=$G(IOBRC)
 ;S YSASBLC=$G(IOBLC),YSASTLC=$G(IOTLC),YSASTRC=$G(IOTRC)
 ;D GKILL^%ZISS
 S X="IOUON;IOUOFF;IOINHI;IOINORM;IOBON;IOBOFF;IORVON;IORVOFF;IOHOME;IOEDEOP"
 D ENDR^%ZISS
 S YSASU0=$G(IOUOFF),YSASU1=$G(IOUON),YSASI0=$G(IOINORM),YSASI1=$G(IOINHI),YSASRV1=$G(IORVON),YSASRV0=$G(IORVOFF)
 S YSASB1=$G(IOBON),YSASB0=$G(IOBOFF)