YSASPNT ;ALB/ASF-TIU PROGRESS NOTE ;10/16/01 10:23
;;5.01;MENTAL HEALTH;**39,73,88,60,187**;Dec 30, 1994;Build 73
;
; reference to ^TMP("TIUP",$J) supported by DBIA 1911
;
MAIN(YSASDA) ;
N VA,VADM,YSASAUTH,YSASC,YSAUTOSG,YSNOW,YSPIFN,YSTIUT,YSTIUTS,G,G2,N,P1,P2,R,V,V1,Y1,YSA,YSAGE,YSAS0,YSASC,YSASD,YSASIG,YSASN,YSASNA,YSASQUIT,YSAST,YSASWP
N YSASWP,YSBID,YSDOB,YSHDR,YSHIML,YSHIMU,YSI,YSJ,YSLAST,YSLCK,YSLFN,YSNM,YSPART,YSPOSL,YSPOSU
N YSPROL,YSPROU,YSSC,YSSCK,YSSEX,YSSSN,YSSTEM,YSTITLE,YSX,YSYCK,YSYX,YSZ,YSZZ,YSV1,YSV2,YSV3,YSV4,YSV5,YSV6,YSV7,YSV8,YSV9,YSV10,YSV11,YSV12,YSV13,YSV14
S Y=$$GET1^DIQ(604,YSASDA,.11,"I") Q:Y'="N" ;---> out if G12 10/16/01 ASF
S YSTIUT=0,YSTIUTS=0 D ASTIT
I (YSTIUT'>0)!(YSTIUTS'?1"ACT".E) W !,"ASI-TIU not fully ready" Q
K DIR S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Do you wish to create a TIU Progress Note" D ^DIR K DIR Q:$D(DIRUT)!(Y'=1)
K DIR S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you wish to automatically sign this note" D ^DIR K DIR Q:$D(DIRUT) S YSAUTOSG=+Y
D NARSET
D PUTPN
;
Q
ASTIT ;ASI document title check
S X="ASI-ADDICTION SEVERITY INDEX",DIC="^TIU(8925.1,",DIC(0)="M",DIC("S")="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC""" D ^DIC K DIC("S") S YSTIUT=+Y Q:YSTIUT'>0
S YSTIUTS=$$GET1^DIQ(8925.1,YSTIUT_",","STATUS")
Q
NARSET ;Set up narrative global
S YSZZ=0
S YSAS0=^YSTX(604,YSASDA,0),DFN=$P(YSAS0,"^",2)
D DEM^VADPT
S YSASD=$$FMTE^XLFDT($P(YSAS0,U,5),"5ZD")
S YSAST=$$GET1^DIQ(604,YSASDA_",",.04)
S YSASC=$$GET1^DIQ(604,YSASDA_",",.09)
S YSASIG=$$GET1^DIQ(604,YSASDA_",",.51,"I")
S YSASAUTH=$$GET1^DIQ(604,YSASDA_",",.09,"I")
S YSNM=VADM(1),YSSEX=$P(VADM(5),U),YSDOB=$P(VADM(3),U,2),YSAGE=VADM(4),YSSSN="xxx-xx-"_VA("BID"),YSBID=VA("BID")
;
K ^TMP($J,"YSTMP"),^TMP("TIUP",$J)
S YSLFN=1,^TMP($J,"YSTMP",0,1,0)=""
D VARPRO^YSASNAR
D R1^YSASNAR
M ^TMP("TIUP",$J)=^TMP($J,"YSTMP",0)
S X="NOW",%DT="T" D ^%DT S YSNOW=Y
S YSLFN=YSLFN-1,^TMP("TIUP",$J,0)="^^"_YSLFN_U_YSLFN_U_YSNOW_U
S YSLFN=0 F S YSLFN=$O(^TMP("TIUP",$J,YSLFN)) Q:YSLFN'>0 S:^TMP("TIUP",$J,YSLFN,0)?1"|BLANK".E ^TMP("TIUP",$J,YSLFN,0)=""
Q
PUTPN ;create Pnote
S YSAUTOSG=$S(YSAUTOSG:YSASAUTH,1:""),TIUASKVS=1
D NEW^TIUPNAPI(.YSPIFN,DFN,YSASAUTH,YSNOW,YSTIUT,"","","",YSAUTOSG,TIUASKVS)
;VMP OIFO BAY PINES;ELR;YS*5.01*88 ADDED NEXT LINE OF CODE
S:$G(YSPIFN)=-1 YSPIFN=0
W !,$S(+YSPIFN:"Progress Note created",1:"Progress Note has NOT been created - please select the existing appointment") H 1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSASPNT 2502 printed Sep 23, 2025@19:49:22 Page 2
YSASPNT ;ALB/ASF-TIU PROGRESS NOTE ;10/16/01 10:23
+1 ;;5.01;MENTAL HEALTH;**39,73,88,60,187**;Dec 30, 1994;Build 73
+2 ;
+3 ; reference to ^TMP("TIUP",$J) supported by DBIA 1911
+4 ;
MAIN(YSASDA) ;
+1 NEW VA,VADM,YSASAUTH,YSASC,YSAUTOSG,YSNOW,YSPIFN,YSTIUT,YSTIUTS,G,G2,N,P1,P2,R,V,V1,Y1,YSA,YSAGE,YSAS0,YSASC,YSASD,YSASIG,YSASN,YSASNA,YSASQUIT,YSAST,YSASWP
+2 NEW YSASWP,YSBID,YSDOB,YSHDR,YSHIML,YSHIMU,YSI,YSJ,YSLAST,YSLCK,YSLFN,YSNM,YSPART,YSPOSL,YSPOSU
+3 NEW YSPROL,YSPROU,YSSC,YSSCK,YSSEX,YSSSN,YSSTEM,YSTITLE,YSX,YSYCK,YSYX,YSZ,YSZZ,YSV1,YSV2,YSV3,YSV4,YSV5,YSV6,YSV7,YSV8,YSV9,YSV10,YSV11,YSV12,YSV13,YSV14
+4 ;---> out if G12 10/16/01 ASF
SET Y=$$GET1^DIQ(604,YSASDA,.11,"I")
if Y'="N"
QUIT
+5 SET YSTIUT=0
SET YSTIUTS=0
DO ASTIT
+6 IF (YSTIUT'>0)!(YSTIUTS'?1"ACT".E)
WRITE !,"ASI-TIU not fully ready"
QUIT
+7 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="Yes"
SET DIR("A")="Do you wish to create a TIU Progress Note"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!(Y'=1)
QUIT
+8 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="No"
SET DIR("A")="Do you wish to automatically sign this note"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET YSAUTOSG=+Y
+9 DO NARSET
+10 DO PUTPN
+11 ;
+12 QUIT
ASTIT ;ASI document title check
+1 SET X="ASI-ADDICTION SEVERITY INDEX"
SET DIC="^TIU(8925.1,"
SET DIC(0)="M"
SET DIC("S")="I $P(^TIU(8925.1,+Y,0),U,4)=""DOC"""
DO ^DIC
KILL DIC("S")
SET YSTIUT=+Y
if YSTIUT'>0
QUIT
+2 SET YSTIUTS=$$GET1^DIQ(8925.1,YSTIUT_",","STATUS")
+3 QUIT
NARSET ;Set up narrative global
+1 SET YSZZ=0
+2 SET YSAS0=^YSTX(604,YSASDA,0)
SET DFN=$PIECE(YSAS0,"^",2)
+3 DO DEM^VADPT
+4 SET YSASD=$$FMTE^XLFDT($PIECE(YSAS0,U,5),"5ZD")
+5 SET YSAST=$$GET1^DIQ(604,YSASDA_",",.04)
+6 SET YSASC=$$GET1^DIQ(604,YSASDA_",",.09)
+7 SET YSASIG=$$GET1^DIQ(604,YSASDA_",",.51,"I")
+8 SET YSASAUTH=$$GET1^DIQ(604,YSASDA_",",.09,"I")
+9 SET YSNM=VADM(1)
SET YSSEX=$PIECE(VADM(5),U)
SET YSDOB=$PIECE(VADM(3),U,2)
SET YSAGE=VADM(4)
SET YSSSN="xxx-xx-"_VA("BID")
SET YSBID=VA("BID")
+10 ;
+11 KILL ^TMP($JOB,"YSTMP"),^TMP("TIUP",$JOB)
+12 SET YSLFN=1
SET ^TMP($JOB,"YSTMP",0,1,0)=""
+13 DO VARPRO^YSASNAR
+14 DO R1^YSASNAR
+15 MERGE ^TMP("TIUP",$JOB)=^TMP($JOB,"YSTMP",0)
+16 SET X="NOW"
SET %DT="T"
DO ^%DT
SET YSNOW=Y
+17 SET YSLFN=YSLFN-1
SET ^TMP("TIUP",$JOB,0)="^^"_YSLFN_U_YSLFN_U_YSNOW_U
+18 SET YSLFN=0
FOR
SET YSLFN=$ORDER(^TMP("TIUP",$JOB,YSLFN))
if YSLFN'>0
QUIT
if ^TMP("TIUP",$JOB,YSLFN,0)?1"|BLANK".E
SET ^TMP("TIUP",$JOB,YSLFN,0)=""
+19 QUIT
PUTPN ;create Pnote
+1 SET YSAUTOSG=$SELECT(YSAUTOSG:YSASAUTH,1:"")
SET TIUASKVS=1
+2 DO NEW^TIUPNAPI(.YSPIFN,DFN,YSASAUTH,YSNOW,YSTIUT,"","","",YSAUTOSG,TIUASKVS)
+3 ;VMP OIFO BAY PINES;ELR;YS*5.01*88 ADDED NEXT LINE OF CODE
+4 if $GET(YSPIFN)=-1
SET YSPIFN=0
+5 WRITE !,$SELECT(+YSPIFN:"Progress Note created",1:"Progress Note has NOT been created - please select the existing appointment")
HANG 1
+6 QUIT
