SDEC48 ;ALB/SAT,WTC - VISTA SCHEDULING RPCS ;Feb 12, 2020@15:22
;;5.3;Scheduling;**627,694**;Aug 13, 1993;Build 61
;
; ICR
; ---
; 7030 - #2 appointment data
; 10035 - #2 demographics
; 10039 - #42 ward location
; 10060 - #200 new person
Q
;
; DAP = return appointment data for given patient - RPC
;
;return formatted appointment data for given patient - RPC
PATAPPTH(SDECY,DFN) ;return patient's appointment history for given patient - RPC
;PATAPPTH(SDECY,DFN) external parameter tag is in SDEC
; RPC Name is SDEC PATIENT HISTORY
; .SDECY = returned pointer to appointment data
; DFN = patient code - pointer to ^DPT(DFN)
N AMN,AMT,AMU,APN,APT,SDECI,SDECTMP,CIN,CIT,CIU,COE,COF,CON,COT,COU,CRM,CRS
N DPTS,DPTSR,NSN,NST,NSU,PAT,PN,RBD,RSD,S,SC,SDCL,SDCLS,SDCLSC,SDW
S SDECI=0
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
S ^TMP("SDEC",$J,0)="T00020ERRORID"_$C(30)
;check for valid Patient
I '+DFN D ERR^SDECERR("Invalid Patient ID.") Q
I '$D(^DPT(DFN,0)) D ERR^SDECERR("Invalid Patient ID.") Q
; data header
S ^TMP("SDEC",$J,0)="T00080TEXT"_$C(30)
S PN=$$GET1^DIQ(2,DFN_",",.01)
S APN=0
S SDCLS=""
S SDCLSC=""
;loop thru patient appointments
S S=0 F S S=$O(^DPT(DFN,"S",S)) Q:S'>0 D
. S DPTS=$G(^DPT(DFN,"S",S,0))
. S DPTSR=$G(^DPT(DFN,"S",S,"R"))
. S SDCL=$P(DPTS,U) ;get clinic
. S PAT="",SC=0 F S SC=$O(^SC(SDCL,"S",S,1,SC)) Q:SC'>0 D Q:PAT=DFN ;get appt record from clinic
. . S SDCLS=$G(^SC(SDCL,"S",S,1,SC,0))
. . S SDCLSC=$G(^SC(SDCL,"S",S,1,SC,"C"))
. . S PAT=$P(SDCLS,U)
. . I PAT=DFN Q
. ;
. S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)="PATIENT NAME: "_PN_$C(30)
. ;
. S SDECTMP="CLINIC: "_$E($$GET1^DIQ(44,SDCL_",",.01),1,37)
. S SDW=$S($D(^DPT(DFN,.1)):^DPT(DFN,.1),1:"Outpatient") ;04 WARD_IEN
. S:SDW'="" SDECTMP=SDECTMP_$$FILL^SDECU(39-$L(SDECTMP))_"WARD: "_$S(+SDW:$$GET1^DIQ(42,SDW_",",.01),1:SDW)
. S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDECTMP_$C(30)
. S SDECTMP=""
. ;
. ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
. ;
. S APT=$$FMTONET^SDECDATE(S,"Y") ;
. ;S APT=$TR($$FMTE^XLFDT(S),"@"," ")
. S SDECTMP="APPT TIME: "_APT
. S APN=APN+1
. S SDECTMP=SDECTMP_$$FILL^SDECU(39-$L(SDECTMP))_"APPT NUMBER: "_APN
. S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDECTMP_$C(30)
. S SDECTMP=""
. ;
. S AMT=$P(DPTS,U,19)
. ;
. ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
. ;
. I AMT'="" S AMT=$$FMTONET^SDECDATE(AMT,"Y") ;
. ;S:AMT'="" AMT=$TR($$FMTE^XLFDT(AMT),"@"," ")
. S:AMT'="" SDECTMP="APPT MADE TIME: "_AMT
. S AMU=$P(DPTS,U,18)
. S AMN=$$GET1^DIQ(200,AMU_",",.01)
. S:AMN'="" SDECTMP=SDECTMP_$$FILL^SDECU(39-$L(SDECTMP))_"APPT MADE BY: "_AMN
. I SDECTMP'="" S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDECTMP_$C(30)
. S SDECTMP=""
. ;
. S RSD=$P(DPTS,U,13)
. ;
. ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
. ;
. I RSD'="" S RSD=$$FMTONET^SDECDATE(RSD,"Y") ;
. ;S:RSD'="" RSD=$TR($$FMTE^XLFDT(RSD),"@"," ")
. I RSD'="" S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)="ROUTING SLIP DATE: "_RSD_$C(30)
. ;
. S CIT=$P(SDCLSC,U)
. ;
. ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
. ;
. I CIT'="" S CIT=$$FMTONET^SDECDATE(CIT,"Y") ;
. ;S:CIT'="" CIT=$TR($$FMTE^XLFDT(CIT),"@"," ")
. S:CIT'="" SDECTMP="CHECKIN TIME: "_CIT
. S CIU=$P(SDCLSC,U,2) ;12 CHECKIN_USER
. S CIN=$$GET1^DIQ(200,CIU_",",.01) ;13 CHECKIN_USER_NAME
. S:CIN'="" SDECTMP=SDECTMP_$$FILL^SDECU(39-$L(SDECTMP))_"CHECKED IN BY: "_CIN
. I SDECTMP'="" S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDECTMP_$C(30)
. S SDECTMP=""
. ;
. S COT=$P(SDCLSC,U,3) ;14 CHECKOUT_TIME
. ;
. ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
. ;
. I COT'="" S COT=$$FMTONET^SDECDATE(COT,"Y") ;
. ;S:COT'="" COT=$TR($$FMTE^XLFDT(COT),"@"," ")
. S:COT'="" SDECTMP="CHECKOUT TIME: "_COT
. S COU=$P(SDCLSC,U,4) ;15 CHECKOUT_USER
. S:COU'="" CON=$$GET1^DIQ(200,COU_",",.01) ;16 CHECKOUT_USER_NAME
. S:$G(CON)'="" SDECTMP=SDECTMP_$$FILL^SDECU(39-$L(SDECTMP))_"CHECKED OUT BY: "_CON
. I SDECTMP'="" S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDECTMP_$C(30)
. S SDECTMP=""
. S COE=$P(SDCLSC,U,6) ;17 CHECKOUT_FILED_TIME
. ;
. ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
. ;
. I COE'="" S COE=$$FMTONET^SDECDATE(COE,"Y") ;
. ;S:COE'="" COE=$TR($$FMTE^XLFDT(COE),"@"," ")
. I COE'="" S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)="CHECKOUT FILED AT: "_COE
. ;
. S NST=$P(DPTS,U,14) ;18 NO_SHO_CANCEL_TIME
. ;
. ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
. ;
. I NST'="" S NST=$$FMTONET^SDECDATE(NST,"Y") ;
. ;S:NST'="" NST=$TR($$FMTE^XLFDT(NST),"@"," ")
. S:NST'="" SDECTMP="NOSHOW CANCEL: "_NST
. S NSU=$P(DPTS,U,12) ;19 NO_SHO_CANCEL_USER
. S:NSU'="" NSN=$$GET1^DIQ(200,NSU_",",.01) ;20 NO_SHO_CANCEL_USER_NAME
. S:$G(NSN)'="" SDECTMP=SDECTMP_$$FILL^SDECU(39-$L(SDECTMP))_"NO SHOW CANCELLED BY: "_$E(NSN,1,17)
. I SDECTMP'="" S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDECTMP_$C(30)
. S SDECTMP=""
. ;
. S COF=$S($P(SDCLSC,U,3)'="":"YES",SDCLSC'="":"NO",1:"") ;21 CHECKED_OUT
. I COF'="" S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)="CHECKED OUT: "_COF_$C(30)
. ;
. S RBD=$P(DPTS,U,10) ;22 REBOOK_DATE
. ;
. ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
. ;
. I RBD'="" S RBD=$$FMTONET^SDECDATE(RBD,"Y") ;
. ;S:RBD'="" RBD=$TR($$FMTE^XLFDT(RBD),"@"," ")
. I RBD'="" S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)="REBOOK DATE: "_RBD_$C(30)
. ;
. S CRS=$P(DPTS,U,15) ;23 CANCEL_REASON
. I CRS'="" S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)="CANCEL REASON: "_$E(CRS,1,63)_$C(30)
. ;
. S CRM=$P(DPTSR,U) ;24 CANCEL_REMARK
. I CRM'="" S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)="CANCEL REMARK: "_$E(CRM,1,63)_$C(30)
. ;
. S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=""_$C(30)
;
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$C(31)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC48 6431 printed Apr 09, 2024@21:47:19 Page 2
SDEC48 ;ALB/SAT,WTC - VISTA SCHEDULING RPCS ;Feb 12, 2020@15:22
+1 ;;5.3;Scheduling;**627,694**;Aug 13, 1993;Build 61
+2 ;
+3 ; ICR
+4 ; ---
+5 ; 7030 - #2 appointment data
+6 ; 10035 - #2 demographics
+7 ; 10039 - #42 ward location
+8 ; 10060 - #200 new person
+9 QUIT
+10 ;
+11 ; DAP = return appointment data for given patient - RPC
+12 ;
+13 ;return formatted appointment data for given patient - RPC
PATAPPTH(SDECY,DFN) ;return patient's appointment history for given patient - RPC
+1 ;PATAPPTH(SDECY,DFN) external parameter tag is in SDEC
+2 ; RPC Name is SDEC PATIENT HISTORY
+3 ; .SDECY = returned pointer to appointment data
+4 ; DFN = patient code - pointer to ^DPT(DFN)
+5 NEW AMN,AMT,AMU,APN,APT,SDECI,SDECTMP,CIN,CIT,CIU,COE,COF,CON,COT,COU,CRM,CRS
+6 NEW DPTS,DPTSR,NSN,NST,NSU,PAT,PN,RBD,RSD,S,SC,SDCL,SDCLS,SDCLSC,SDW
+7 SET SDECI=0
+8 KILL ^TMP("SDEC",$JOB)
+9 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+10 SET ^TMP("SDEC",$JOB,0)="T00020ERRORID"_$CHAR(30)
+11 ;check for valid Patient
+12 IF '+DFN
DO ERR^SDECERR("Invalid Patient ID.")
QUIT
+13 IF '$DATA(^DPT(DFN,0))
DO ERR^SDECERR("Invalid Patient ID.")
QUIT
+14 ; data header
+15 SET ^TMP("SDEC",$JOB,0)="T00080TEXT"_$CHAR(30)
+16 SET PN=$$GET1^DIQ(2,DFN_",",.01)
+17 SET APN=0
+18 SET SDCLS=""
+19 SET SDCLSC=""
+20 ;loop thru patient appointments
+21 SET S=0
FOR
SET S=$ORDER(^DPT(DFN,"S",S))
if S'>0
QUIT
Begin DoDot:1
+22 SET DPTS=$GET(^DPT(DFN,"S",S,0))
+23 SET DPTSR=$GET(^DPT(DFN,"S",S,"R"))
+24 ;get clinic
SET SDCL=$PIECE(DPTS,U)
+25 ;get appt record from clinic
SET PAT=""
SET SC=0
FOR
SET SC=$ORDER(^SC(SDCL,"S",S,1,SC))
if SC'>0
QUIT
Begin DoDot:2
+26 SET SDCLS=$GET(^SC(SDCL,"S",S,1,SC,0))
+27 SET SDCLSC=$GET(^SC(SDCL,"S",S,1,SC,"C"))
+28 SET PAT=$PIECE(SDCLS,U)
+29 IF PAT=DFN
QUIT
End DoDot:2
if PAT=DFN
QUIT
+30 ;
+31 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)="PATIENT NAME: "_PN_$CHAR(30)
+32 ;
+33 SET SDECTMP="CLINIC: "_$EXTRACT($$GET1^DIQ(44,SDCL_",",.01),1,37)
+34 ;04 WARD_IEN
SET SDW=$SELECT($DATA(^DPT(DFN,.1)):^DPT(DFN,.1),1:"Outpatient")
+35 if SDW'=""
SET SDECTMP=SDECTMP_$$FILL^SDECU(39-$LENGTH(SDECTMP))_"WARD: "_$SELECT(+SDW:$$GET1^DIQ(42,SDW_",",.01),1:SDW)
+36 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECTMP_$CHAR(30)
+37 SET SDECTMP=""
+38 ;
+39 ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
+40 ;
+41 ;
SET APT=$$FMTONET^SDECDATE(S,"Y")
+42 ;S APT=$TR($$FMTE^XLFDT(S),"@"," ")
+43 SET SDECTMP="APPT TIME: "_APT
+44 SET APN=APN+1
+45 SET SDECTMP=SDECTMP_$$FILL^SDECU(39-$LENGTH(SDECTMP))_"APPT NUMBER: "_APN
+46 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECTMP_$CHAR(30)
+47 SET SDECTMP=""
+48 ;
+49 SET AMT=$PIECE(DPTS,U,19)
+50 ;
+51 ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
+52 ;
+53 ;
IF AMT'=""
SET AMT=$$FMTONET^SDECDATE(AMT,"Y")
+54 ;S:AMT'="" AMT=$TR($$FMTE^XLFDT(AMT),"@"," ")
+55 if AMT'=""
SET SDECTMP="APPT MADE TIME: "_AMT
+56 SET AMU=$PIECE(DPTS,U,18)
+57 SET AMN=$$GET1^DIQ(200,AMU_",",.01)
+58 if AMN'=""
SET SDECTMP=SDECTMP_$$FILL^SDECU(39-$LENGTH(SDECTMP))_"APPT MADE BY: "_AMN
+59 IF SDECTMP'=""
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECTMP_$CHAR(30)
+60 SET SDECTMP=""
+61 ;
+62 SET RSD=$PIECE(DPTS,U,13)
+63 ;
+64 ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
+65 ;
+66 ;
IF RSD'=""
SET RSD=$$FMTONET^SDECDATE(RSD,"Y")
+67 ;S:RSD'="" RSD=$TR($$FMTE^XLFDT(RSD),"@"," ")
+68 IF RSD'=""
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)="ROUTING SLIP DATE: "_RSD_$CHAR(30)
+69 ;
+70 SET CIT=$PIECE(SDCLSC,U)
+71 ;
+72 ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
+73 ;
+74 ;
IF CIT'=""
SET CIT=$$FMTONET^SDECDATE(CIT,"Y")
+75 ;S:CIT'="" CIT=$TR($$FMTE^XLFDT(CIT),"@"," ")
+76 if CIT'=""
SET SDECTMP="CHECKIN TIME: "_CIT
+77 ;12 CHECKIN_USER
SET CIU=$PIECE(SDCLSC,U,2)
+78 ;13 CHECKIN_USER_NAME
SET CIN=$$GET1^DIQ(200,CIU_",",.01)
+79 if CIN'=""
SET SDECTMP=SDECTMP_$$FILL^SDECU(39-$LENGTH(SDECTMP))_"CHECKED IN BY: "_CIN
+80 IF SDECTMP'=""
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECTMP_$CHAR(30)
+81 SET SDECTMP=""
+82 ;
+83 ;14 CHECKOUT_TIME
SET COT=$PIECE(SDCLSC,U,3)
+84 ;
+85 ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
+86 ;
+87 ;
IF COT'=""
SET COT=$$FMTONET^SDECDATE(COT,"Y")
+88 ;S:COT'="" COT=$TR($$FMTE^XLFDT(COT),"@"," ")
+89 if COT'=""
SET SDECTMP="CHECKOUT TIME: "_COT
+90 ;15 CHECKOUT_USER
SET COU=$PIECE(SDCLSC,U,4)
+91 ;16 CHECKOUT_USER_NAME
if COU'=""
SET CON=$$GET1^DIQ(200,COU_",",.01)
+92 if $GET(CON)'=""
SET SDECTMP=SDECTMP_$$FILL^SDECU(39-$LENGTH(SDECTMP))_"CHECKED OUT BY: "_CON
+93 IF SDECTMP'=""
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECTMP_$CHAR(30)
+94 SET SDECTMP=""
+95 ;17 CHECKOUT_FILED_TIME
SET COE=$PIECE(SDCLSC,U,6)
+96 ;
+97 ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
+98 ;
+99 ;
IF COE'=""
SET COE=$$FMTONET^SDECDATE(COE,"Y")
+100 ;S:COE'="" COE=$TR($$FMTE^XLFDT(COE),"@"," ")
+101 IF COE'=""
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)="CHECKOUT FILED AT: "_COE
+102 ;
+103 ;18 NO_SHO_CANCEL_TIME
SET NST=$PIECE(DPTS,U,14)
+104 ;
+105 ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
+106 ;
+107 ;
IF NST'=""
SET NST=$$FMTONET^SDECDATE(NST,"Y")
+108 ;S:NST'="" NST=$TR($$FMTE^XLFDT(NST),"@"," ")
+109 if NST'=""
SET SDECTMP="NOSHOW CANCEL: "_NST
+110 ;19 NO_SHO_CANCEL_USER
SET NSU=$PIECE(DPTS,U,12)
+111 ;20 NO_SHO_CANCEL_USER_NAME
if NSU'=""
SET NSN=$$GET1^DIQ(200,NSU_",",.01)
+112 if $GET(NSN)'=""
SET SDECTMP=SDECTMP_$$FILL^SDECU(39-$LENGTH(SDECTMP))_"NO SHOW CANCELLED BY: "_$EXTRACT(NSN,1,17)
+113 IF SDECTMP'=""
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECTMP_$CHAR(30)
+114 SET SDECTMP=""
+115 ;
+116 ;21 CHECKED_OUT
SET COF=$SELECT($PIECE(SDCLSC,U,3)'="":"YES",SDCLSC'="":"NO",1:"")
+117 IF COF'=""
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)="CHECKED OUT: "_COF_$CHAR(30)
+118 ;
+119 ;22 REBOOK_DATE
SET RBD=$PIECE(DPTS,U,10)
+120 ;
+121 ; Change date/time conversion so midnight is handled properly. wtc 694 5/17/18
+122 ;
+123 ;
IF RBD'=""
SET RBD=$$FMTONET^SDECDATE(RBD,"Y")
+124 ;S:RBD'="" RBD=$TR($$FMTE^XLFDT(RBD),"@"," ")
+125 IF RBD'=""
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)="REBOOK DATE: "_RBD_$CHAR(30)
+126 ;
+127 ;23 CANCEL_REASON
SET CRS=$PIECE(DPTS,U,15)
+128 IF CRS'=""
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)="CANCEL REASON: "_$EXTRACT(CRS,1,63)_$CHAR(30)
+129 ;
+130 ;24 CANCEL_REMARK
SET CRM=$PIECE(DPTSR,U)
+131 IF CRM'=""
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)="CANCEL REMARK: "_$EXTRACT(CRM,1,63)_$CHAR(30)
+132 ;
+133 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=""_$CHAR(30)
End DoDot:1
+134 ;
+135 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(31)
+136 QUIT
