SDECRECREQ ;ALB/SAT/JSM,WTC,LAB,LEG,KML - VISTA SCHEDULING RPCS (SOURCE FROM SDEC08) ;April 20, 2022
;;5.3;Scheduling;**790,792,805,815**;Aug 13, 1993;Build 4
;;Per VHA Directive 2004-038, this routine should not be modified
;
; Reference to ^DPT (Patient File) is supported by IA #7030
Q
;
RECREQ(SDECY,SDECAPTID,SDAPTYP,NEWPID,SDECTYP) ;for Recall Requests
; VSE-863; 6/6/2021 ; create new "APPT" Request if A "RECALL" Appt is Cancelled
;I $P(SDAPTYP,";",2)="SD(403.5," D ; RECALL
N PTR,SD40350PRV,SD40350REC,SD40354PRV,SD4035IEN,SD409840REC,SD409842REC,SDCLN,SDCLNR,SDPROVNAM,IEN40985,SD409841COM
N CANCHANGEPID,PIDH,RECOPENYN
S SD409840REC=^SDEC(409.84,SDECAPTID,0) ; APPT
; Only re-open Appt Request for approved Cancellation Reasons VSE-1112
S RECOPENYN=$$GET1^DIQ(409.2,$P(SD409840REC,U,22),5,"I")
Q:RECOPENYN=0
S SD409842REC=$G(^SDEC(409.84,SDECAPTID,2)) ; REQ record
; start COMMENTS multiple process ;VSE-1218;**792
S SD409841COM=$G(^SDEC(409.84,SDECAPTID,1,1,0))
N I,L,ZZ
S L=$L(SD409841COM,$C(13,10))
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
; end COMMENTS multiple process
S PTR=$P(SD409842REC,";",1)
S SDCLNR=$P(SD409840REC,U,7)
S SDCLN=$$GET1^DIQ(409.831,SDCLNR,.04,"I")
S SDECFDA(409.85,"+1,",.01)=$P(SD409840REC,U,5) ; DFN
S SDECFDA(409.85,"+1,",1)=$P($$NOW^XLFDT,".",1)
S SDECFDA(409.85,"+1,",2)=$$GET1^DIQ(44,SDCLN,3,"I") ;INSTIT
S SDECFDA(409.85,"+1,",4)="APPT"
S SDECFDA(409.85,"+1,",8.7)=$P(SD409840REC,U,6) ; REQ APPT TIME
S SDECFDA(409.85,"+1,",.02)=$P(SD409842REC,U,2) ; PAT STATUS
S SDECFDA(409.85,"+1,",8)=SDCLN ; REQ SPECIFIC CLINIC
S SDECFDA(409.85,"+1,",9)=DUZ ; ORIG USER
S SDECFDA(409.85,"+1,",10)="F" ; PRIORITY
S SDECFDA(409.85,"+1,",11)=1 ; REQ BY
S SDECFDA(409.85,"+1,",12)=$P(SD409840REC,"^",16) ; PROV
I $G(NEWPID)="" D
.S SDECFDA(409.85,"+1,",22)=$P(SD409840REC,U,20) ; PID
I $G(NEWPID)'="" D
.S SDECFDA(409.85,"+1,",22)=NEWPID
S SDECFDA(409.85,"+1,",23)="O" ; STATUS
S SDECFDA(409.85,"+1,",25)=SD409841COM ;VSE-1218;**792
;**790 corrected REQUEST ptr and added Contact Attempts
S CANCHANGEPID=$S($G(SDECTYP)="PC":1,$G(SDECTYP)="C":0,1:"")
S SDECFDA(409.85,"+1,",49)=CANCHANGEPID
D UPDATE^DIE("","SDECFDA","IEN40985")
;I $G(NEWPID)'="" D
I $G(NEWPID)="" S PIDH=$P(SD409840REC,U,20)
I $G(NEWPID)'="" S PIDH=$G(NEWPID)
S FDA(409.854,"+1,"_IEN40985(1)_",",.01)=$$NOW^XLFDT
S FDA(409.854,"+1,"_IEN40985(1)_",",1)=$G(PIDH)
S FDA(409.854,"+1,"_IEN40985(1)_",",2)=$$GET1^DIQ(200,DUZ,.01,"E")
D UPDATE^DIE(,"FDA","PIDHIEN","ERR") K FDA
S IEN40985=IEN40985(1)
N REQLINK,DFN40985
D APPREQLINK
D CONTACTLINK
Q
APPREQLINK ; Associate new APPT Req vs. old RECALL Req
S DFN40985=$P(SD409840REC,U,5)
S REQLINK=IEN40985_";SDEC(409.85,"
S $P(^SDEC(409.84,SDECAPTID,2),"^",1)=REQLINK
Q
CONTACTLINK ; update contact attempts
N IEN40986,REC409860,REC
S IEN40986="",REC=0
F S IEN40986=$O(^SDEC(409.86,"B",DFN40985,IEN40986)) Q:IEN40986=""!(REC=1) D
.S REC409860=$G(^SDEC(409.86,IEN40986,0))
.I PTR'=+$P(REC409860,"^",7) Q ; SDEC Req
.K SDECFDA
.S SDECFDA(409.86,IEN40986_",",2.1)="A"
.S SDECFDA(409.86,IEN40986_",",2.2)=$P(^SDEC(409.86,IEN40986,1,0),"^",3)+1 ;**792 ;Main Sequence
.S SDECFDA(409.86,IEN40986_",",2.3)=REQLINK
.D UPDATE^DIE("","SDECFDA")
.S REC=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECRECREQ 3538 printed Dec 13, 2024@02:52:27 Page 2
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
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 ;
+4 ; Reference to ^DPT (Patient File) is supported by IA #7030
+5 QUIT
+6 ;
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
+2 ;I $P(SDAPTYP,";",2)="SD(403.5," D ; RECALL
+3 NEW PTR,SD40350PRV,SD40350REC,SD40354PRV,SD4035IEN,SD409840REC,SD409842REC,SDCLN,SDCLNR,SDPROVNAM,IEN40985,SD409841COM
+4 NEW CANCHANGEPID,PIDH,RECOPENYN
+5 ; APPT
SET SD409840REC=^SDEC(409.84,SDECAPTID,0)
+6 ; Only re-open Appt Request for approved Cancellation Reasons VSE-1112
+7 SET RECOPENYN=$$GET1^DIQ(409.2,$PIECE(SD409840REC,U,22),5,"I")
+8 if RECOPENYN=0
QUIT
+9 ; REQ record
SET SD409842REC=$GET(^SDEC(409.84,SDECAPTID,2))
+10 ; start COMMENTS multiple process ;VSE-1218;**792
+11 SET SD409841COM=$GET(^SDEC(409.84,SDECAPTID,1,1,0))
+12 NEW I,L,ZZ
+13 SET L=$LENGTH(SD409841COM,$CHAR(13,10))
+14 IF L>1
FOR I=1:1:L
SET $PIECE(ZZ," | ",I)=$PIECE(SD409841COM,$CHAR(13,10),I)
IF I=L
if $LENGTH(ZZ)>80
SET ZZ=$EXTRACT(ZZ,1,77)_"..."
SET SD409841COM=ZZ
+15 ; end COMMENTS multiple process
+16 SET PTR=$PIECE(SD409842REC,";",1)
+17 SET SDCLNR=$PIECE(SD409840REC,U,7)
+18 SET SDCLN=$$GET1^DIQ(409.831,SDCLNR,.04,"I")
+19 ; DFN
SET SDECFDA(409.85,"+1,",.01)=$PIECE(SD409840REC,U,5)
+20 SET SDECFDA(409.85,"+1,",1)=$PIECE($$NOW^XLFDT,".",1)
+21 ;INSTIT
SET SDECFDA(409.85,"+1,",2)=$$GET1^DIQ(44,SDCLN,3,"I")
+22 SET SDECFDA(409.85,"+1,",4)="APPT"
+23 ; REQ APPT TIME
SET SDECFDA(409.85,"+1,",8.7)=$PIECE(SD409840REC,U,6)
+24 ; PAT STATUS
SET SDECFDA(409.85,"+1,",.02)=$PIECE(SD409842REC,U,2)
+25 ; REQ SPECIFIC CLINIC
SET SDECFDA(409.85,"+1,",8)=SDCLN
+26 ; ORIG USER
SET SDECFDA(409.85,"+1,",9)=DUZ
+27 ; PRIORITY
SET SDECFDA(409.85,"+1,",10)="F"
+28 ; REQ BY
SET SDECFDA(409.85,"+1,",11)=1
+29 ; PROV
SET SDECFDA(409.85,"+1,",12)=$PIECE(SD409840REC,"^",16)
+30 IF $GET(NEWPID)=""
Begin DoDot:1
+31 ; PID
SET SDECFDA(409.85,"+1,",22)=$PIECE(SD409840REC,U,20)
End DoDot:1
+32 IF $GET(NEWPID)'=""
Begin DoDot:1
+33 SET SDECFDA(409.85,"+1,",22)=NEWPID
End DoDot:1
+34 ; STATUS
SET SDECFDA(409.85,"+1,",23)="O"
+35 ;VSE-1218;**792
SET SDECFDA(409.85,"+1,",25)=SD409841COM
+36 ;**790 corrected REQUEST ptr and added Contact Attempts
+37 SET CANCHANGEPID=$SELECT($GET(SDECTYP)="PC":1,$GET(SDECTYP)="C":0,1:"")
+38 SET SDECFDA(409.85,"+1,",49)=CANCHANGEPID
+39 DO UPDATE^DIE("","SDECFDA","IEN40985")
+40 ;I $G(NEWPID)'="" D
+41 IF $GET(NEWPID)=""
SET PIDH=$PIECE(SD409840REC,U,20)
+42 IF $GET(NEWPID)'=""
SET PIDH=$GET(NEWPID)
+43 SET FDA(409.854,"+1,"_IEN40985(1)_",",.01)=$$NOW^XLFDT
+44 SET FDA(409.854,"+1,"_IEN40985(1)_",",1)=$GET(PIDH)
+45 SET FDA(409.854,"+1,"_IEN40985(1)_",",2)=$$GET1^DIQ(200,DUZ,.01,"E")
+46 DO UPDATE^DIE(,"FDA","PIDHIEN","ERR")
KILL FDA
+47 SET IEN40985=IEN40985(1)
+48 NEW REQLINK,DFN40985
+49 DO APPREQLINK
+50 DO CONTACTLINK
+51 QUIT
APPREQLINK ; Associate new APPT Req vs. old RECALL Req
+1 SET DFN40985=$PIECE(SD409840REC,U,5)
+2 SET REQLINK=IEN40985_";SDEC(409.85,"
+3 SET $PIECE(^SDEC(409.84,SDECAPTID,2),"^",1)=REQLINK
+4 QUIT
CONTACTLINK ; update contact attempts
+1 NEW IEN40986,REC409860,REC
+2 SET IEN40986=""
SET REC=0
+3 FOR
SET IEN40986=$ORDER(^SDEC(409.86,"B",DFN40985,IEN40986))
if IEN40986=""!(REC=1)
QUIT
Begin DoDot:1
+4 SET REC409860=$GET(^SDEC(409.86,IEN40986,0))
+5 ; SDEC Req
IF PTR'=+$PIECE(REC409860,"^",7)
QUIT
+6 KILL SDECFDA
+7 SET SDECFDA(409.86,IEN40986_",",2.1)="A"
+8 ;**792 ;Main Sequence
SET SDECFDA(409.86,IEN40986_",",2.2)=$PIECE(^SDEC(409.86,IEN40986,1,0),"^",3)+1
+9 SET SDECFDA(409.86,IEN40986_",",2.3)=REQLINK
+10 DO UPDATE^DIE("","SDECFDA")
+11 SET REC=1
End DoDot:1
+12 QUIT
