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

SDECRECREQ.m

Go to the documentation of this file.
  1. SDECRECREQ ;ALB/SAT/JSM,WTC,LAB,LEG,KML - VISTA SCHEDULING RPCS (SOURCE FROM SDEC08) ;April 20, 2022
  1. ;;5.3;Scheduling;**790,792,805,815**;Aug 13, 1993;Build 4
  1. ;;Per VHA Directive 2004-038, this routine should not be modified
  1. ;
  1. ; Reference to ^DPT (Patient File) is supported by IA #7030
  1. Q
  1. ;
  1. RECREQ(SDECY,SDECAPTID,SDAPTYP,NEWPID,SDECTYP) ;for Recall Requests
  1. ; VSE-863; 6/6/2021 ; create new "APPT" Request if A "RECALL" Appt is Cancelled
  1. ;I $P(SDAPTYP,";",2)="SD(403.5," D ; RECALL
  1. N PTR,SD40350PRV,SD40350REC,SD40354PRV,SD4035IEN,SD409840REC,SD409842REC,SDCLN,SDCLNR,SDPROVNAM,IEN40985,SD409841COM
  1. N CANCHANGEPID,PIDH,RECOPENYN
  1. S SD409840REC=^SDEC(409.84,SDECAPTID,0) ; APPT
  1. ; Only re-open Appt Request for approved Cancellation Reasons VSE-1112
  1. S RECOPENYN=$$GET1^DIQ(409.2,$P(SD409840REC,U,22),5,"I")
  1. Q:RECOPENYN=0
  1. S SD409842REC=$G(^SDEC(409.84,SDECAPTID,2)) ; REQ record
  1. ; start COMMENTS multiple process ;VSE-1218;**792
  1. S SD409841COM=$G(^SDEC(409.84,SDECAPTID,1,1,0))
  1. N I,L,ZZ
  1. S L=$L(SD409841COM,$C(13,10))
  1. I L>1 F I=1:1:L S $P(ZZ," | ",I)=$P(SD409841COM,$C(13,10),I) I I=L S:$L(ZZ)>80 ZZ=$E(ZZ,1,77)_"..." S SD409841COM=ZZ
  1. ; end COMMENTS multiple process
  1. S PTR=$P(SD409842REC,";",1)
  1. S SDCLNR=$P(SD409840REC,U,7)
  1. S SDCLN=$$GET1^DIQ(409.831,SDCLNR,.04,"I")
  1. S SDECFDA(409.85,"+1,",.01)=$P(SD409840REC,U,5) ; DFN
  1. S SDECFDA(409.85,"+1,",1)=$P($$NOW^XLFDT,".",1)
  1. S SDECFDA(409.85,"+1,",2)=$$GET1^DIQ(44,SDCLN,3,"I") ;INSTIT
  1. S SDECFDA(409.85,"+1,",4)="APPT"
  1. S SDECFDA(409.85,"+1,",8.7)=$P(SD409840REC,U,6) ; REQ APPT TIME
  1. S SDECFDA(409.85,"+1,",.02)=$P(SD409842REC,U,2) ; PAT STATUS
  1. S SDECFDA(409.85,"+1,",8)=SDCLN ; REQ SPECIFIC CLINIC
  1. S SDECFDA(409.85,"+1,",9)=DUZ ; ORIG USER
  1. S SDECFDA(409.85,"+1,",10)="F" ; PRIORITY
  1. S SDECFDA(409.85,"+1,",11)=1 ; REQ BY
  1. S SDECFDA(409.85,"+1,",12)=$P(SD409840REC,"^",16) ; PROV
  1. I $G(NEWPID)="" D
  1. .S SDECFDA(409.85,"+1,",22)=$P(SD409840REC,U,20) ; PID
  1. I $G(NEWPID)'="" D
  1. .S SDECFDA(409.85,"+1,",22)=NEWPID
  1. S SDECFDA(409.85,"+1,",23)="O" ; STATUS
  1. S SDECFDA(409.85,"+1,",25)=SD409841COM ;VSE-1218;**792
  1. ;**790 corrected REQUEST ptr and added Contact Attempts
  1. S CANCHANGEPID=$S($G(SDECTYP)="PC":1,$G(SDECTYP)="C":0,1:"")
  1. S SDECFDA(409.85,"+1,",49)=CANCHANGEPID
  1. D UPDATE^DIE("","SDECFDA","IEN40985")
  1. ;I $G(NEWPID)'="" D
  1. I $G(NEWPID)="" S PIDH=$P(SD409840REC,U,20)
  1. I $G(NEWPID)'="" S PIDH=$G(NEWPID)
  1. S FDA(409.854,"+1,"_IEN40985(1)_",",.01)=$$NOW^XLFDT
  1. S FDA(409.854,"+1,"_IEN40985(1)_",",1)=$G(PIDH)
  1. S FDA(409.854,"+1,"_IEN40985(1)_",",2)=$$GET1^DIQ(200,DUZ,.01,"E")
  1. D UPDATE^DIE(,"FDA","PIDHIEN","ERR") K FDA
  1. S IEN40985=IEN40985(1)
  1. N REQLINK,DFN40985
  1. D APPREQLINK
  1. D CONTACTLINK
  1. Q
  1. S DFN40985=$P(SD409840REC,U,5)
  1. S REQLINK=IEN40985_";SDEC(409.85,"
  1. S $P(^SDEC(409.84,SDECAPTID,2),"^",1)=REQLINK
  1. Q
  1. N IEN40986,REC409860,REC
  1. S IEN40986="",REC=0
  1. F S IEN40986=$O(^SDEC(409.86,"B",DFN40985,IEN40986)) Q:IEN40986=""!(REC=1) D
  1. .S REC409860=$G(^SDEC(409.86,IEN40986,0))
  1. .I PTR'=+$P(REC409860,"^",7) Q ; SDEC Req
  1. .K SDECFDA
  1. .S SDECFDA(409.86,IEN40986_",",2.1)="A"
  1. .S SDECFDA(409.86,IEN40986_",",2.2)=$P(^SDEC(409.86,IEN40986,1,0),"^",3)+1 ;**792 ;Main Sequence
  1. .S SDECFDA(409.86,IEN40986_",",2.3)=REQLINK
  1. .D UPDATE^DIE("","SDECFDA")
  1. .S REC=1
  1. Q