YTQCONS ;ASF/ALB - MHA3 CONSULTS ; 8/1/11 2:30pm
;;5.01;MENTAL HEALTH;**103,123,187**;Dec 30, 1994;Build 73
;
;Reference to TIUPUTU API supported by DBIA #3351
;Reference to TIUSRVA API supported by DBIA #5541
;Reference to VADPT API supported by DBIA #10061
;Reference to TIUSRVP API supported by DBIA #3535
;Reference to PXAPI API supported by DBIA #1889
;Reference to TIUSRVR1 API supported by DBIA #2944
;Reference to ^GMR(123 global supported by DBIA #2586
;Reference to ORQQCN1 API supported by DBIA #5608
;Reference to TIUCNSLT API supported by DBIA #5546
;Reference to TIUSRVR API supported by DBIA #3436
;Reference to FILE 8925 supported by DBIA #3268
;Reference to FILE 8925.1 supported by DBIA #5540
;Reference to FILE 9.4 supported by DBIA #10048
Q
CCREATE(YSDATA,YS) ;consult entry
;Input AD AS ien of 601.84 mh administration
; YS(1...X) as text of note
N DFN,N,N1,N2,Y,Y1,J1,J2,YSAD,YSAVED,YSHOSP,YSOK,YSORD,YSRPRIVL,YST,YSTIT,YSTS,YSVISIT,YSVSIT,YSVSTR,YST1,YSTIUX,YSTIUDA
N YSPNOK,YSINS,YSPNAC,YSPNTIT,VA,VADM,X,YSAGE,YSB,YSDOB,YSG,YSHDR,YSNM,YSSEX,YSSSN,YSCREQ,YSPCS,YSCON,YSISC
S YSDATA(1)="[ERROR]"
S YSAD=$G(YS("AD"),0)
I '$D(^YTT(601.84,YSAD,0)) S YSDATA(2)="bad ad" Q ;-->out
S YSHOSP=$P(^YTT(601.84,YSAD,0),U,11)
I YSHOSP'>0 S YSDATA(2)="no location" Q ;-->out
S YSPCS=$G(YS("COSIGNER")) ;ASF 8/1/20011
S DFN=$$GET1^DIQ(601.84,YSAD_",",1,"I")
I DFN'>0 S YSDATA(2)="bad dfn" Q ;-->out
S YSAVED=$$GET1^DIQ(601.84,YSAD_",",4,"I")
S YSORD=$$GET1^DIQ(601.84,YSAD_",",5,"I")
;check consult request
S YSCON=$G(YS("CON"),0)
I '$D(^GMR(123,YSCON,0)) S YSDATA(2)="bad consult/request" Q ;-->out
D GETCSLT^ORQQCN1(.Y,YSCON)
S YSTIUDA=$P(Y(0),U,20)
;
;asf 3/10/08 create pnote only when GENERATE '=n and not inactive
S YSINS=$$GET1^DIQ(601.84,YSAD_",",2,"I")
S YSPNOK=$$GET1^DIQ(601.71,YSINS_",",28,"I")
Q:YSPNOK="N" ;-->out no note for this test
S YSPNTIT=$$GET1^DIQ(601.71,YSINS_",",30,"E")
S Y=$$WHATITLE^TIUPUTU(YSPNTIT)
D ISCNSLT^TIUCNSLT(.YSISC,+Y)
IF YSISC=0 S Y=$$WHATITLE^TIUPUTU("MHA CONSULT")
I Y'>0 S YSDATA(2)="pn not setup" Q ;--->out
S YSTIT=+Y
;
S YSTS=$$GET1^DIQ(601.84,YSAD_",",2,"I")
S YSRPRIVL=$$GET1^DIQ(601.71,YSTS_",",9,"E")
Q:YSRPRIVL'="" ;-->out ASF 5/1/07
;
;set cosigner if required or exit ASF 3/14/08
D REQCOS^TIUSRVA(.YSCREQ,YSTIT,"",YSORD,"") ;is cosigner required
; ASF 8/1/2011
;D GETPREF^TIUSRVR(.Y1,YSORD) S YSPCS=$P(Y1,U,9) ; is preferred cosigner set
Q:YSCREQ&(YSPCS="") ;-->out required signer not set
S:YSCREQ&(YSPCS>0) YSTIUX(1208)=YSPCS,YSTIUX(1506)=1
S YSTIUX(1202)=YSORD
;
D DEM^VADPT,PID^VADPT S YSNM=VADM(1),YSSEX=$P(VADM(5),U),YSDOB=$P(VADM(3),U,2),YSAGE=VADM(4),YSSSN="xxx-xx-"_VA("BID")
S $P(YSHDR," ",60)="",YSHDR=YSSSN_" "_YSNM_YSHDR,YSHDR=$E(YSHDR,1,44)_YSSEX_" AGE "_YSAGE
;D BOTTOM ;add boilerplate at end
I YSTIUDA>0 D UPDATE Q ;-->out
;
D TXTCK(0)
;MAKE(SUCCESS,DFN,TITLE,VDT,VLOC,VSIT,TIUX,VSTR,SUPPRESS,NOASF)
D MAKE^TIUSRVP(.YSOK,DFN,YSTIT,YSAVED,YSHOSP,,.YSTIUX,YSHOSP_";"_YSAVED_";E")
S ^TMP("YSCON",$J,"ysok")=YSOK
Q:YSOK'>0 ;-->out
;
LINK ;link to request
N DIE,DA,DR,YSCVP,YSTVP,YSERR
I +YSOK'>0 Q ;-->out
S YSCVP=YSCON_";GMR(123,"
S DIE=8925,DA=+YSOK,DR="1405////^S X=YSCVP"
D ^DIE
;*** modified by FT on 6/29/11
N YSFDA
S YSFDA(123.03,"+1,"_YSCON_",",.01)=YSOK_";TIU(8925,"
D UPDATE^DIE("","YSFDA","YSERR")
I $D(YSERR("DIERR")) S YSDATA(1)="[ERROR]",YSDATA(2)="Unable to link to Consult" Q ;-->out
;***
S YSDATA(1)="[DATA]",YSDATA(2)=YSOK
N YSENC,YSPKG,YSEOK,YSPROB
S YSVISIT=$$GET1^DIQ(8925,YSOK_",",.03,"I")
S YSPKG=$$FIND1^DIC(9.4,"","BO","MENTAL HEALTH")
S YSENC("ENCOUNTER",1,"ENC D/T")=YSAVED
S YSENC("ENCOUNTER",1,"PATIENT")=DFN
S YSENC("ENCOUNTER",1,"HOS LOC")=YSHOSP
S YSENC("ENCOUNTER",1,"SERVICE CATEGORY")="E"
S YSENC("ENCOUNTER",1,"ENCOUNTER TYPE")="O"
S YSENC("PROVIDER",1,"NAME")=YSORD
S YSENC("PROVIDER",1,"PRIMARY")=1
S YSEOK=$$DATA2PCE^PXAPI("YSENC",YSPKG,"MHA DATA",.YSVISIT,,,,,.YSPROB)
Q
UPDATE ;
K ^TMP("TIUVIEW",$J)
D TGET^TIUSRVR1(.YST1,YSTIUDA)
S N1=4,N2=0 ;keep from adding header each time
F S N1=$O(^TMP("TIUVIEW",$J,N1)) Q:N1'>0 S N2=N2+1,YSTIUX("TEXT",N2,0)=^TMP("TIUVIEW",$J,N1)
K ^TMP("TIUVIEW",$J)
S YSTIUX(.02)=DFN
S YSTIUX(1301)=YSAVED
S YSTIUX(1302)=YSORD
S $P(X,"_",75)=""
S N2=N2+1,YSTIUX("TEXT",N2,0)=X
D TXTCK(N2)
D UPDATE^TIUSRVP(.YSOK,YSTIUDA,.YSTIUX)
S:YSOK YSDATA(1)="[DATA]",YSDATA(2)=YSOK
Q
TXTCK(N2) ;clean text
S N=0,N1=0 F S N=$O(YS(N)) Q:N'>0 D
. S YSG=YS(N)
. I YSG="" S YSB=$G(YSB)+1
. E S YSB=0
. I (YSG="")&(YSB>2) Q ;no print mult blanks
. I N>3 Q:($E(YSG,1,51)=$E(YSHDR,1,51))
. I N>3 Q:YSG?." "1"PRINTED ENTERED"." "
. Q:YSG?1"Not valid unless signed: Reviewed by".E
. Q:YSG?1"Printed by: ".E
. S N1=N1+1
. S YSTIUX("TEXT",N1+N2,0)=YS(N) K YS(N)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQCONS 4951 printed Dec 13, 2024@02:18:26 Page 2
YTQCONS ;ASF/ALB - MHA3 CONSULTS ; 8/1/11 2:30pm
+1 ;;5.01;MENTAL HEALTH;**103,123,187**;Dec 30, 1994;Build 73
+2 ;
+3 ;Reference to TIUPUTU API supported by DBIA #3351
+4 ;Reference to TIUSRVA API supported by DBIA #5541
+5 ;Reference to VADPT API supported by DBIA #10061
+6 ;Reference to TIUSRVP API supported by DBIA #3535
+7 ;Reference to PXAPI API supported by DBIA #1889
+8 ;Reference to TIUSRVR1 API supported by DBIA #2944
+9 ;Reference to ^GMR(123 global supported by DBIA #2586
+10 ;Reference to ORQQCN1 API supported by DBIA #5608
+11 ;Reference to TIUCNSLT API supported by DBIA #5546
+12 ;Reference to TIUSRVR API supported by DBIA #3436
+13 ;Reference to FILE 8925 supported by DBIA #3268
+14 ;Reference to FILE 8925.1 supported by DBIA #5540
+15 ;Reference to FILE 9.4 supported by DBIA #10048
+16 QUIT
CCREATE(YSDATA,YS) ;consult entry
+1 ;Input AD AS ien of 601.84 mh administration
+2 ; YS(1...X) as text of note
+3 NEW DFN,N,N1,N2,Y,Y1,J1,J2,YSAD,YSAVED,YSHOSP,YSOK,YSORD,YSRPRIVL,YST,YSTIT,YSTS,YSVISIT,YSVSIT,YSVSTR,YST1,YSTIUX,YSTIUDA
+4 NEW YSPNOK,YSINS,YSPNAC,YSPNTIT,VA,VADM,X,YSAGE,YSB,YSDOB,YSG,YSHDR,YSNM,YSSEX,YSSSN,YSCREQ,YSPCS,YSCON,YSISC
+5 SET YSDATA(1)="[ERROR]"
+6 SET YSAD=$GET(YS("AD"),0)
+7 ;-->out
IF '$DATA(^YTT(601.84,YSAD,0))
SET YSDATA(2)="bad ad"
QUIT
+8 SET YSHOSP=$PIECE(^YTT(601.84,YSAD,0),U,11)
+9 ;-->out
IF YSHOSP'>0
SET YSDATA(2)="no location"
QUIT
+10 ;ASF 8/1/20011
SET YSPCS=$GET(YS("COSIGNER"))
+11 SET DFN=$$GET1^DIQ(601.84,YSAD_",",1,"I")
+12 ;-->out
IF DFN'>0
SET YSDATA(2)="bad dfn"
QUIT
+13 SET YSAVED=$$GET1^DIQ(601.84,YSAD_",",4,"I")
+14 SET YSORD=$$GET1^DIQ(601.84,YSAD_",",5,"I")
+15 ;check consult request
+16 SET YSCON=$GET(YS("CON"),0)
+17 ;-->out
IF '$DATA(^GMR(123,YSCON,0))
SET YSDATA(2)="bad consult/request"
QUIT
+18 DO GETCSLT^ORQQCN1(.Y,YSCON)
+19 SET YSTIUDA=$PIECE(Y(0),U,20)
+20 ;
+21 ;asf 3/10/08 create pnote only when GENERATE '=n and not inactive
+22 SET YSINS=$$GET1^DIQ(601.84,YSAD_",",2,"I")
+23 SET YSPNOK=$$GET1^DIQ(601.71,YSINS_",",28,"I")
+24 ;-->out no note for this test
if YSPNOK="N"
QUIT
+25 SET YSPNTIT=$$GET1^DIQ(601.71,YSINS_",",30,"E")
+26 SET Y=$$WHATITLE^TIUPUTU(YSPNTIT)
+27 DO ISCNSLT^TIUCNSLT(.YSISC,+Y)
+28 IF YSISC=0
SET Y=$$WHATITLE^TIUPUTU("MHA CONSULT")
+29 ;--->out
IF Y'>0
SET YSDATA(2)="pn not setup"
QUIT
+30 SET YSTIT=+Y
+31 ;
+32 SET YSTS=$$GET1^DIQ(601.84,YSAD_",",2,"I")
+33 SET YSRPRIVL=$$GET1^DIQ(601.71,YSTS_",",9,"E")
+34 ;-->out ASF 5/1/07
if YSRPRIVL'=""
QUIT
+35 ;
+36 ;set cosigner if required or exit ASF 3/14/08
+37 ;is cosigner required
DO REQCOS^TIUSRVA(.YSCREQ,YSTIT,"",YSORD,"")
+38 ; ASF 8/1/2011
+39 ;D GETPREF^TIUSRVR(.Y1,YSORD) S YSPCS=$P(Y1,U,9) ; is preferred cosigner set
+40 ;-->out required signer not set
if YSCREQ&(YSPCS="")
QUIT
+41 if YSCREQ&(YSPCS>0)
SET YSTIUX(1208)=YSPCS
SET YSTIUX(1506)=1
+42 SET YSTIUX(1202)=YSORD
+43 ;
+44 DO DEM^VADPT
DO PID^VADPT
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")
+45 SET $PIECE(YSHDR," ",60)=""
SET YSHDR=YSSSN_" "_YSNM_YSHDR
SET YSHDR=$EXTRACT(YSHDR,1,44)_YSSEX_" AGE "_YSAGE
+46 ;D BOTTOM ;add boilerplate at end
+47 ;-->out
IF YSTIUDA>0
DO UPDATE
QUIT
+48 ;
+49 DO TXTCK(0)
+50 ;MAKE(SUCCESS,DFN,TITLE,VDT,VLOC,VSIT,TIUX,VSTR,SUPPRESS,NOASF)
+51 DO MAKE^TIUSRVP(.YSOK,DFN,YSTIT,YSAVED,YSHOSP,,.YSTIUX,YSHOSP_";"_YSAVED_";E")
+52 SET ^TMP("YSCON",$JOB,"ysok")=YSOK
+53 ;-->out
if YSOK'>0
QUIT
+54 ;
LINK ;link to request
+1 NEW DIE,DA,DR,YSCVP,YSTVP,YSERR
+2 ;-->out
IF +YSOK'>0
QUIT
+3 SET YSCVP=YSCON_";GMR(123,"
+4 SET DIE=8925
SET DA=+YSOK
SET DR="1405////^S X=YSCVP"
+5 DO ^DIE
+6 ;*** modified by FT on 6/29/11
+7 NEW YSFDA
+8 SET YSFDA(123.03,"+1,"_YSCON_",",.01)=YSOK_";TIU(8925,"
+9 DO UPDATE^DIE("","YSFDA","YSERR")
+10 ;-->out
IF $DATA(YSERR("DIERR"))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="Unable to link to Consult"
QUIT
+11 ;***
+12 SET YSDATA(1)="[DATA]"
SET YSDATA(2)=YSOK
+13 NEW YSENC,YSPKG,YSEOK,YSPROB
+14 SET YSVISIT=$$GET1^DIQ(8925,YSOK_",",.03,"I")
+15 SET YSPKG=$$FIND1^DIC(9.4,"","BO","MENTAL HEALTH")
+16 SET YSENC("ENCOUNTER",1,"ENC D/T")=YSAVED
+17 SET YSENC("ENCOUNTER",1,"PATIENT")=DFN
+18 SET YSENC("ENCOUNTER",1,"HOS LOC")=YSHOSP
+19 SET YSENC("ENCOUNTER",1,"SERVICE CATEGORY")="E"
+20 SET YSENC("ENCOUNTER",1,"ENCOUNTER TYPE")="O"
+21 SET YSENC("PROVIDER",1,"NAME")=YSORD
+22 SET YSENC("PROVIDER",1,"PRIMARY")=1
+23 SET YSEOK=$$DATA2PCE^PXAPI("YSENC",YSPKG,"MHA DATA",.YSVISIT,,,,,.YSPROB)
+24 QUIT
UPDATE ;
+1 KILL ^TMP("TIUVIEW",$JOB)
+2 DO TGET^TIUSRVR1(.YST1,YSTIUDA)
+3 ;keep from adding header each time
SET N1=4
SET N2=0
+4 FOR
SET N1=$ORDER(^TMP("TIUVIEW",$JOB,N1))
if N1'>0
QUIT
SET N2=N2+1
SET YSTIUX("TEXT",N2,0)=^TMP("TIUVIEW",$JOB,N1)
+5 KILL ^TMP("TIUVIEW",$JOB)
+6 SET YSTIUX(.02)=DFN
+7 SET YSTIUX(1301)=YSAVED
+8 SET YSTIUX(1302)=YSORD
+9 SET $PIECE(X,"_",75)=""
+10 SET N2=N2+1
SET YSTIUX("TEXT",N2,0)=X
+11 DO TXTCK(N2)
+12 DO UPDATE^TIUSRVP(.YSOK,YSTIUDA,.YSTIUX)
+13 if YSOK
SET YSDATA(1)="[DATA]"
SET YSDATA(2)=YSOK
+14 QUIT
TXTCK(N2) ;clean text
+1 SET N=0
SET N1=0
FOR
SET N=$ORDER(YS(N))
if N'>0
QUIT
Begin DoDot:1
+2 SET YSG=YS(N)
+3 IF YSG=""
SET YSB=$GET(YSB)+1
+4 IF '$TEST
SET YSB=0
+5 ;no print mult blanks
IF (YSG="")&(YSB>2)
QUIT
+6 IF N>3
if ($EXTRACT(YSG,1,51)=$EXTRACT(YSHDR,1,51))
QUIT
+7 IF N>3
if YSG?." "1"PRINTED ENTERED"." "
QUIT
+8 if YSG?1"Not valid unless signed
QUIT
+9 if YSG?1"Printed by
QUIT
+10 SET N1=N1+1
+11 SET YSTIUX("TEXT",N1+N2,0)=YS(N)
KILL YS(N)
End DoDot:1
+12 QUIT
