SDESRECALLREQ ;ALB/BWF/BLB,BLB/JAS - VISTA SCHEDULING RECALL/APPT REQUEST RPCS ; Mar 19, 2024@10:30am
;;5.3;Scheduling;**835,847,853,875,877**;Aug 13, 1993;Build 14
;;Per VHA Directive 6402, this routine should not be modified
Q
REOPEN(RETURN,APPTIEN,SDAPTYP,NEWPID,SDECTYP,NOSHOWFLAG,USERID) ;for Recall Requests
N OLDPTR,SD40350PRV,SD40350REC,SD40354PRV,SD4035IEN,SD409840REC,SD409842REC,CLINIC,RESOURCE,SDPROVNAM,IEN40985,SD409841COM,REQIEN
N CANCHANGEPID,PIDH,RECOPENYN,APPTDAT,ERR,APPTIENS,CANREASONPTR,CLINIC,DFN40984,DFN40985,FDA,INSTIEN,REQUEST,I,LENGTH,COMMENT
S APPTIENS=APPTIEN_","
D GETS^DIQ(409.84,APPTIENS,".05;.06;.07;.122;.16;.2;.22;.23","I","APPTDAT","ERR")
I $D(ERR) Q
S SD409840REC=^SDEC(409.84,APPTIEN,0) ; APPT
; Only re-open Appt Request for approved Cancellation Reasons VSE-1112
S CANREASONPTR=$G(APPTDAT(409.84,APPTIENS,.122,"I"))
S RECOPENYN=$$GET1^DIQ(409.2,CANREASONPTR,5,"I")
Q:RECOPENYN=0
S OLDPTR=$P($G(APPTDAT(409.84,APPTIENS,.22,"I")),";")
S SD409841COM=$G(^SDEC(409.84,APPTIEN,1,1,0))
S LENGTH=$L(SD409841COM,$C(13,10))
I LENGTH>1 D
.F I=1:1:LENGTH S $P(COMMENT," | ",I)=$P(SD409841COM,$C(13,10),I) I I=LENGTH S:$L(COMMENT)>80 COMMENT=$E(COMMENT,1,77)_"..." S SD409841COM=COMMENT
S RESOURCE=$G(APPTDAT(409.84,APPTIENS,.07,"I"))
S CLINIC=$$GET1^DIQ(409.831,RESOURCE,.04,"I")
S DFN40984=$G(APPTDAT(409.84,APPTIENS,.05,"I"))
S REQUEST("DFN")=DFN40984
S REQUEST("CREATE DATE")=$P($$NOW^XLFDT,".",1)
S INSTIEN=$$GET1^DIQ(44,CLINIC,3,"I")
S REQUEST("REQUEST SUB TYPE")="APPT"
S REQUEST("APPOINTMENT TYPE IEN")=$G(APPTDAT(409.84,APPTIENS,.06,"I"))
S REQUEST("APPOINTMENT TYPE")=$G(APPTDAT(409.84,APPTIENS,.06,"I"))
S REQUEST("PATIENT STATUS")=$G(APPTDAT(409.84,APPTIENS,.23,"I"))
S REQUEST("CLINIC IEN")=CLINIC
S REQUEST("PRIORITY")="F"
S REQUEST("REQUESTED BY")=1
S REQUEST("PROVIDER IEN")=$G(APPTDAT(409.84,APPTIENS,.16,"I"))
I $G(NEWPID)="" D
.S REQUEST("PATIENT INDICATED DATE")=$G(APPTDAT(409.84,APPTIENS,.2,"I"))
I $G(NEWPID)'="" D
.S REQUEST("PATIENT INDICATED DATE")=NEWPID
S REQUEST("REQUEST COMMENT")=SD409841COM
S CANCHANGEPID=$S($G(SDECTYP)="PC":1,$G(SDECTYP)="C":0,$G(NOSHOWFLAG)=1:1,1:"")
S REQUEST("PID CHANGE ALLOWED")=CANCHANGEPID
S REQIEN=$$BUILDER^SDES2CRTAPREQ(.REQUEST,INSTIEN,$S($G(USERID):USERID,1:DUZ))
S REQLINK=REQIEN_";SDEC(409.85,"
D APPREQLINK(APPTIEN,REQIEN,REQLINK)
S RETURN=$G(REQIEN)_U_$G(REQLINK)_U_$G(OLDPTR)
Q
; update PID history
APPREQLINK(APPTIEN,IEN40985,REQLINK) ; Associate new APPT Req vs. old RECALL Req
N FDA
S FDA(409.84,APPTIEN_",",.22)=REQLINK
D FILE^DIE(,"FDA") K FDA
Q
WPSTR(ARR) ;convert WP field array to single string ;alb/sat 658
N RET,WPI
S RET=""
Q:'$D(ARR) RET
S WPI=0 F S WPI=$O(ARR(WPI)) Q:WPI="" D
.S RET=RET_ARR(WPI)
Q RET
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDESRECALLREQ 2830 printed Oct 16, 2024@18:58:02 Page 2
SDESRECALLREQ ;ALB/BWF/BLB,BLB/JAS - VISTA SCHEDULING RECALL/APPT REQUEST RPCS ; Mar 19, 2024@10:30am
+1 ;;5.3;Scheduling;**835,847,853,875,877**;Aug 13, 1993;Build 14
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 QUIT
REOPEN(RETURN,APPTIEN,SDAPTYP,NEWPID,SDECTYP,NOSHOWFLAG,USERID) ;for Recall Requests
+1 NEW OLDPTR,SD40350PRV,SD40350REC,SD40354PRV,SD4035IEN,SD409840REC,SD409842REC,CLINIC,RESOURCE,SDPROVNAM,IEN40985,SD409841COM,REQIEN
+2 NEW CANCHANGEPID,PIDH,RECOPENYN,APPTDAT,ERR,APPTIENS,CANREASONPTR,CLINIC,DFN40984,DFN40985,FDA,INSTIEN,REQUEST,I,LENGTH,COMMENT
+3 SET APPTIENS=APPTIEN_","
+4 DO GETS^DIQ(409.84,APPTIENS,".05;.06;.07;.122;.16;.2;.22;.23","I","APPTDAT","ERR")
+5 IF $DATA(ERR)
QUIT
+6 ; APPT
SET SD409840REC=^SDEC(409.84,APPTIEN,0)
+7 ; Only re-open Appt Request for approved Cancellation Reasons VSE-1112
+8 SET CANREASONPTR=$GET(APPTDAT(409.84,APPTIENS,.122,"I"))
+9 SET RECOPENYN=$$GET1^DIQ(409.2,CANREASONPTR,5,"I")
+10 if RECOPENYN=0
QUIT
+11 SET OLDPTR=$PIECE($GET(APPTDAT(409.84,APPTIENS,.22,"I")),";")
+12 SET SD409841COM=$GET(^SDEC(409.84,APPTIEN,1,1,0))
+13 SET LENGTH=$LENGTH(SD409841COM,$CHAR(13,10))
+14 IF LENGTH>1
Begin DoDot:1
+15 FOR I=1:1:LENGTH
SET $PIECE(COMMENT," | ",I)=$PIECE(SD409841COM,$CHAR(13,10),I)
IF I=LENGTH
if $LENGTH(COMMENT)>80
SET COMMENT=$EXTRACT(COMMENT,1,77)_"..."
SET SD409841COM=COMMENT
End DoDot:1
+16 SET RESOURCE=$GET(APPTDAT(409.84,APPTIENS,.07,"I"))
+17 SET CLINIC=$$GET1^DIQ(409.831,RESOURCE,.04,"I")
+18 SET DFN40984=$GET(APPTDAT(409.84,APPTIENS,.05,"I"))
+19 SET REQUEST("DFN")=DFN40984
+20 SET REQUEST("CREATE DATE")=$PIECE($$NOW^XLFDT,".",1)
+21 SET INSTIEN=$$GET1^DIQ(44,CLINIC,3,"I")
+22 SET REQUEST("REQUEST SUB TYPE")="APPT"
+23 SET REQUEST("APPOINTMENT TYPE IEN")=$GET(APPTDAT(409.84,APPTIENS,.06,"I"))
+24 SET REQUEST("APPOINTMENT TYPE")=$GET(APPTDAT(409.84,APPTIENS,.06,"I"))
+25 SET REQUEST("PATIENT STATUS")=$GET(APPTDAT(409.84,APPTIENS,.23,"I"))
+26 SET REQUEST("CLINIC IEN")=CLINIC
+27 SET REQUEST("PRIORITY")="F"
+28 SET REQUEST("REQUESTED BY")=1
+29 SET REQUEST("PROVIDER IEN")=$GET(APPTDAT(409.84,APPTIENS,.16,"I"))
+30 IF $GET(NEWPID)=""
Begin DoDot:1
+31 SET REQUEST("PATIENT INDICATED DATE")=$GET(APPTDAT(409.84,APPTIENS,.2,"I"))
End DoDot:1
+32 IF $GET(NEWPID)'=""
Begin DoDot:1
+33 SET REQUEST("PATIENT INDICATED DATE")=NEWPID
End DoDot:1
+34 SET REQUEST("REQUEST COMMENT")=SD409841COM
+35 SET CANCHANGEPID=$SELECT($GET(SDECTYP)="PC":1,$GET(SDECTYP)="C":0,$GET(NOSHOWFLAG)=1:1,1:"")
+36 SET REQUEST("PID CHANGE ALLOWED")=CANCHANGEPID
+37 SET REQIEN=$$BUILDER^SDES2CRTAPREQ(.REQUEST,INSTIEN,$SELECT($GET(USERID):USERID,1:DUZ))
+38 SET REQLINK=REQIEN_";SDEC(409.85,"
+39 DO APPREQLINK(APPTIEN,REQIEN,REQLINK)
+40 SET RETURN=$GET(REQIEN)_U_$GET(REQLINK)_U_$GET(OLDPTR)
+41 QUIT
+42 ; update PID history
APPREQLINK(APPTIEN,IEN40985,REQLINK) ; Associate new APPT Req vs. old RECALL Req
+1 NEW FDA
+2 SET FDA(409.84,APPTIEN_",",.22)=REQLINK
+3 DO FILE^DIE(,"FDA")
KILL FDA
+4 QUIT
WPSTR(ARR) ;convert WP field array to single string ;alb/sat 658
+1 NEW RET,WPI
+2 SET RET=""
+3 if '$DATA(ARR)
QUIT RET
+4 SET WPI=0
FOR
SET WPI=$ORDER(ARR(WPI))
if WPI=""
QUIT
Begin DoDot:1
+5 SET RET=RET_ARR(WPI)
End DoDot:1
+6 QUIT RET
