- 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 Feb 19, 2025@00:18:53 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