YSASA2 ;ASF/ALB-ASI QUICK ENTRY ;3/19/98 15:08
;;5.01;MENTAL HEALTH;**24,30,32,38,121**;Dec 30, 1994;Build 61
;Reference to VADPT APIs supported by DBIA #10061
;Reference to ^%ZIS supported by DBIA #10086
;Reference to ^%ZISS supported by DBIA #10088
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)_" "_"xxx-xx-"_$E($P(VADM(2),U,2),8,11) 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=$$GET1^DID(604,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
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)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSASA2 4527 printed Nov 22, 2024@17:23 Page 2
YSASA2 ;ASF/ALB-ASI QUICK ENTRY ;3/19/98 15:08
+1 ;;5.01;MENTAL HEALTH;**24,30,32,38,121**;Dec 30, 1994;Build 61
+2 ;Reference to VADPT APIs supported by DBIA #10061
+3 ;Reference to ^%ZIS supported by DBIA #10086
+4 ;Reference to ^%ZISS supported by DBIA #10088
+5 QUIT
AA(YSASPIEN,YSASTYP) ;Add NEW RECORD
+1 if $GET(YSASPIEN)'>0
QUIT
+2 if $GET(YSASTYP)'>0
QUIT
+3 NEW YSASGE,YSASRACE,YSASREL,YSASU0,YSASU1,YSASNEW,YSASNM
+4 NEW YSASSEX,YSASG0,YSASG1,YSASHL,YSASI0,YSASI1,YSASLT,YSASVL,YSASTT,YSASTRC
+5 NEW YSASBLC,YSASTLC,YSASTRC,YSASDFLT
+6 NEW YSASBT,YSASBRC
+7 ;age and name
NEW YSASN
+8 NEW IOHG,IOINHI,IOINORM,IOUOFF,IOUON
+9 NEW DIC,DA,X,Y,DDSFILE,DR,DLAYGO,DIERR
+10 SET Y=YSASPIEN
SET Y(0)=^DPT(Y,0)
+11 WRITE !!,"...reading Patient information..."
+12 SET YSASRACE=$$RACE^YSASLIB($PIECE(Y(0),"^",6))
SET YSASREL=$$REL^YSASLIB($PIECE(Y(0),"^",8))
SET YSASSEX=$PIECE(Y(0),"^",2)
+13 SET YSASGE=$$GET1^DIQ(2,+Y_",","AGE")
SET YSASNM=$PIECE(Y(0),U)
+14 WRITE !,"...creating new ASI record..."
+15 SET DLAYGO=604
+16 SET DIC="^YSTX(604,"
SET DIC(0)="L"
SET X="NEW"
+17 DO ^DIC
+18 if Y'>0
QUIT
+19 SET YSASSIEN=+Y
SET YSASNEW=$PIECE(Y,"^",3)=1
+20 NEW DIE,DA,DR,X,Y,YSAS,YSASF,YSASV,YSAS033,YSASC,YSASDF,YSASLR
+21 SET DIE=DIC
SET DA=YSASSIEN
+22 SET DR=".02///`"_YSASPIEN
+23 SET DR=DR_";.04///"_YSASTYP
+24 ;ASF 6/24
SET DR=DR_";.05///NOW;.09////"_DUZ
+25 if YSASRACE]""
SET DR=DR_";.16///"_YSASRACE
+26 if YSASREL]""
SET DR=DR_";.17///"_YSASREL
+27 DO ^DIE
+28 ;
+29 QUIT
MAIN(YSASPIEN,YSASSIEN) ;
+1 if $GET(YSASSIEN)'>0
QUIT
+2 if $GET(YSASPIEN)'>0
QUIT
+3 DO SCREENH
+4 SET YSIENS=YSASSIEN_","
+5 SET YSASTYP=$$GET1^DIQ(604,YSIENS,"CLASS")
+6 SET YSGP=$SELECT(YSASTYP?1"L".E:5,YSASTYP?1"FO".E:6,1:4)
+7 SET DFN=YSASPIEN
DO DEM^VADPT
SET YSHDR1=VADM(1)_" "_"xxx-xx-"_$EXTRACT($PIECE(VADM(2),U,2),8,11)
DO KVAR^VADPT
+8 SET YSHDR2="Addiction Severity Index "_YSASTYP
+9 WRITE @IOF,YSHDR1,?45,YSASI1,YSHDR2,YSASI0,!
+10 SET YSFILE=604
SET YSFLAG="EF"
+11 SET YSFDA="^TMP($J,""YSASI"")"
+12 KILL ^TMP($JOB,"YSASI")
+13 SET YSDFLAG=$$GET1^DIQ(604.8,"1,",.04)
+14 SET YSEFLAG=$$GET1^DIQ(604.8,"1,",.07)
+15 SET YSN=0
SET YSV=""
LOOP ;
+1 FOR
SET YSN=$ORDER(^YSTX(604.66,YSN))
if YSN'>0!(YSV="^")
QUIT
SET YSENDLP=0
DO L3
+2 WRITE !
+3 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="Yes"
SET DIR("A")="Save editing session"
DO ^DIR
KILL DIR
+4 if 'Y
QUIT
+5 DO FILE^DIE("K","^TMP($J,""YSASI"")")
WP ;
+1 KILL DIRUT,DIR
FOR
if $DATA(DIRUT)
QUIT
Begin DoDot:1
+2 WRITE !?10,"*** Comments ***",!,"1. General Info",?20,"2. Medical",?40,"3. Employment",?60,"4. Drug/Alcohol"
+3 WRITE !,"5. Legal",?20,"6. Family hx",?40,"7. Social",?60,"8. Psychiatric"
+4 WRITE !,"9. Spiritual",?19,"10. Leisure",!
+5 KILL DIR
SET DIR("A")="Enter Comment for? "
SET DIR(0)="NO^1:10:0"
DO ^DIR
+6 if $DATA(DIRUT)
QUIT
+7 SET DR=$SELECT(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)
+8 SET DA=YSASSIEN
SET DIE="^YSTX(604,"
+9 DO ^DIE
+10 QUIT
End DoDot:1
+11 ;
+12 DO EN^YSASSN(YSASSIEN)
+13 QUIT
L3 ;
+1 SET YSG=^YSTX(604.66,YSN,0)
SET YSFIELD=+$PIECE(YSG,U,3)
SET YSQ=$PIECE(YSG,U,2)
SET YSDEF=$PIECE(YSG,U,7)
SET YSASENT=$PIECE(YSG,U,9)
+2 SET YSASEX=$GET(^YSTX(604.66,YSN,1))
+3 if $PIECE(YSG,U,YSGP)=""
QUIT
+4 if $Y+4>IOSL
WRITE @IOF,YSHDR1,?45,YSASI1,YSHDR2,YSASI0,!
+5 ;quit if executable sets flag
if YSENDLP
QUIT
+6 IF YSASENT'=""
WRITE YSASI1
XECUTE YSASENT
WRITE YSASI0
L4 ;No form feed
+1 DO FDAGET
SET YSP=Y
+2 if YSP=""!(YSP="^")
SET YSP=$$GET1^DIQ(604,YSIENS,YSFIELD)
+3 ; SET DEFAULT IF FLAG SET
IF YSP=""
IF YSDFLAG="YES"
SET YSP=YSDEF
+4 WRITE !,$SELECT($PIECE(^YSTX(604.66,YSN,0),U,10)=1&(YSASTYP="FOLLOWUP"):"* ",1:""),YSQ,$SELECT(YSP="":": ",1:": "_YSP_" // ")
+5 READ YSV:DTIME
if '$TEST
SET YSV="^"
+6 if YSV=""
SET YSV=YSP
+7 if YSV=""!(YSV="^")
QUIT
+8 IF YSV?1"^"1A1N.E
Begin DoDot:1
+9 IF YSV?1"^"1L.N
SET YSV="^"_$CHAR($ASCII(YSV,2)-32)_$EXTRACT(YSV,3,9)
+10 SET (YSNN,YSNN1)=0
+11 SET YSNN=$ORDER(^YSTX(604.66,"C",$EXTRACT(YSV,2,9)))
+12 if $EXTRACT(YSNN,1,$LENGTH(YSV)-1)'=$EXTRACT(YSV,2,9)
QUIT
+13 if $LENGTH(YSNN)
SET YSNN1=$ORDER(^YSTX(604.66,"C",YSNN,-1))
+14 if YSNN1
SET YSN=YSNN1-.01
End DoDot:1
if YSNN1'=0
QUIT
+15 ;
+16 IF YSV?1"?".E
WRITE YSASI1
Begin DoDot:1
+17 SET YSATRIB=$$GET1^DID(604,YSFIELD,"","POINTER")
+18 IF YSATRIB?1"YSTX".E
SET DIC="^"_YSATRIB
SET DIC(0)="FIS"
SET D="B"
DO DQ^DICQ
KILL DIC,DIE,DID,D,DIX,DO
+19 IF YSATRIB'?1"YSTX".E
DO HELP^DIE(YSFILE,"",YSFIELD,"?",YSFDA)
DO MSG^DIALOG("WH","","","",YSFDA)
+20 QUIT
End DoDot:1
WRITE YSASI0
KILL YSATRIB
GOTO L4
+21 ;ASF 5/16
if YSV?1N.N
SET YSV=+YSV
+22 DO VAL
+23 IF YSA="^"
WRITE $CHAR(7)
DO HELP^DIE(YSFILE,"",YSFIELD,"?",YSFDA)
DO MSG^DIALOG("WH","","","",YSFDA)
GOTO L4
+24 WRITE ?$X+3,YSA(0)
+25 ; branch if parameters allowed
IF YSEFLAG="YES"
XECUTE YSASEX
+26 QUIT
VAL ;
+1 DO VAL^DIE(YSFILE,YSIENS,YSFIELD,YSFLAG,YSV,.YSA,YSFDA,"^TMP($J,""YSASERR"")")
+2 QUIT
FDAGET ;
+1 SET Y=$$VALUE1^DILF(YSFILE,YSFIELD,YSFDA)
+2 if Y'=""&(Y'="^")
SET Y=$$EXTERNAL^DILFD(YSFILE,YSFIELD,"",Y)
+3 QUIT
SCREENH ;
+1 if '$DATA(IOST)
DO HOME^%ZIS
+2 SET X="IOUON;IOUOFF;IOINHI;IOINORM;IOBON;IOBOFF;IORVON;IORVOFF;IOHOME;IOEDEOP"
+3 DO ENDR^%ZISS
+4 SET YSASU0=$GET(IOUOFF)
SET YSASU1=$GET(IOUON)
SET YSASI0=$GET(IOINORM)
SET YSASI1=$GET(IOINHI)
SET YSASRV1=$GET(IORVON)
SET YSASRV0=$GET(IORVOFF)
+5 SET YSASB1=$GET(IOBON)
SET YSASB0=$GET(IOBOFF)
