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

SDESRECALLREQ.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 6402, this routine should not be modified
  1. Q
  1. REOPEN(RETURN,APPTIEN,SDAPTYP,NEWPID,SDECTYP,NOSHOWFLAG,USERID) ;for Recall Requests
  1. N OLDPTR,SD40350PRV,SD40350REC,SD40354PRV,SD4035IEN,SD409840REC,SD409842REC,CLINIC,RESOURCE,SDPROVNAM,IEN40985,SD409841COM,REQIEN
  1. N CANCHANGEPID,PIDH,RECOPENYN,APPTDAT,ERR,APPTIENS,CANREASONPTR,CLINIC,DFN40984,DFN40985,FDA,INSTIEN,REQUEST,I,LENGTH,COMMENT
  1. S APPTIENS=APPTIEN_","
  1. D GETS^DIQ(409.84,APPTIENS,".05;.06;.07;.122;.16;.2;.22;.23","I","APPTDAT","ERR")
  1. I $D(ERR) Q
  1. S SD409840REC=^SDEC(409.84,APPTIEN,0) ; APPT
  1. ; Only re-open Appt Request for approved Cancellation Reasons VSE-1112
  1. S CANREASONPTR=$G(APPTDAT(409.84,APPTIENS,.122,"I"))
  1. S RECOPENYN=$$GET1^DIQ(409.2,CANREASONPTR,5,"I")
  1. Q:RECOPENYN=0
  1. S OLDPTR=$P($G(APPTDAT(409.84,APPTIENS,.22,"I")),";")
  1. S SD409841COM=$G(^SDEC(409.84,APPTIEN,1,1,0))
  1. S LENGTH=$L(SD409841COM,$C(13,10))
  1. I LENGTH>1 D
  1. .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
  1. S RESOURCE=$G(APPTDAT(409.84,APPTIENS,.07,"I"))
  1. S CLINIC=$$GET1^DIQ(409.831,RESOURCE,.04,"I")
  1. S DFN40984=$G(APPTDAT(409.84,APPTIENS,.05,"I"))
  1. S REQUEST("DFN")=DFN40984
  1. S REQUEST("CREATE DATE")=$P($$NOW^XLFDT,".",1)
  1. S INSTIEN=$$GET1^DIQ(44,CLINIC,3,"I")
  1. S REQUEST("REQUEST SUB TYPE")="APPT"
  1. S REQUEST("APPOINTMENT TYPE IEN")=$G(APPTDAT(409.84,APPTIENS,.06,"I"))
  1. S REQUEST("APPOINTMENT TYPE")=$G(APPTDAT(409.84,APPTIENS,.06,"I"))
  1. S REQUEST("PATIENT STATUS")=$G(APPTDAT(409.84,APPTIENS,.23,"I"))
  1. S REQUEST("CLINIC IEN")=CLINIC
  1. S REQUEST("PRIORITY")="F"
  1. S REQUEST("REQUESTED BY")=1
  1. S REQUEST("PROVIDER IEN")=$G(APPTDAT(409.84,APPTIENS,.16,"I"))
  1. I $G(NEWPID)="" D
  1. .S REQUEST("PATIENT INDICATED DATE")=$G(APPTDAT(409.84,APPTIENS,.2,"I"))
  1. I $G(NEWPID)'="" D
  1. .S REQUEST("PATIENT INDICATED DATE")=NEWPID
  1. S REQUEST("REQUEST COMMENT")=SD409841COM
  1. S CANCHANGEPID=$S($G(SDECTYP)="PC":1,$G(SDECTYP)="C":0,$G(NOSHOWFLAG)=1:1,1:"")
  1. S REQUEST("PID CHANGE ALLOWED")=CANCHANGEPID
  1. S REQIEN=$$BUILDER^SDES2CRTAPREQ(.REQUEST,INSTIEN,$S($G(USERID):USERID,1:DUZ))
  1. S REQLINK=REQIEN_";SDEC(409.85,"
  1. D APPREQLINK(APPTIEN,REQIEN,REQLINK)
  1. S RETURN=$G(REQIEN)_U_$G(REQLINK)_U_$G(OLDPTR)
  1. Q
  1. ; update PID history
  1. N FDA
  1. S FDA(409.84,APPTIEN_",",.22)=REQLINK
  1. D FILE^DIE(,"FDA") K FDA
  1. Q
  1. WPSTR(ARR) ;convert WP field array to single string ;alb/sat 658
  1. N RET,WPI
  1. S RET=""
  1. Q:'$D(ARR) RET
  1. S WPI=0 F S WPI=$O(ARR(WPI)) Q:WPI="" D
  1. .S RET=RET_ARR(WPI)
  1. Q RET