Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YTQCONS

YTQCONS.m

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