- 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 Feb 19, 2025@00:24:09 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