- 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 Jan 18, 2025@03:19:33 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