Changeset 1563 for Scheduling


Ignore:
Timestamp:
Oct 8, 2012, 6:59:10 AM (12 years ago)
Author:
Tariq Hamkari
Message:

updated the BSDX version to 1.7

  • fix "BSDX01.m" routine , it was take too long time to retrieve patient radiology exams.
Location:
Scheduling/trunk/m
Files:
41 edited

Legend:

Unmodified
Added
Removed
  • Scheduling/trunk/m/BSDX01.m

    r1481 r1563  
    1 BSDX01  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/6/12 10:52am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     1BSDX01  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 5/16/11 2:46pm
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
     
    282282        ;
    283283INDIV(BSDXSC)   ; PEP - Is ^SC clinic in the same DUZ(2) as user?
    284         ; Input: BSDXSC - Hospital Location IEN
    285         ; Output: True or False
    286         I '+BSDXSC QUIT 1  ;If not tied to clinic, yes
    287         I '$D(^SC(BSDXSC,0)) QUIT 1 ; If Clinic does not exist, yes
    288         ; Jump to Division:Medical Center Division:Inst File Pointer for
    289         ; Institution IEN (and get its internal value)
    290         N DIV S DIV=$$GET1^DIQ(44,BSDXSC_",","3.5:.07","I")
    291         I DIV="" Q 1 ; If clinic has no division, consider it avial to user.
    292         I DIV=DUZ(2) Q 1 ; If same, then User is in same Div as Clinic
    293         E  Q 0 ; Otherwise, no
     284           ; Input: BSDXSC - Hospital Location IEN
     285           ; Output: True or False
     286           I '+BSDXSC QUIT 1  ;If not tied to clinic, yes
     287           I '$D(^SC(BSDXSC,0)) QUIT 1 ; If Clinic does not exist, yes
     288           ; Jump to Division:Medical Center Division:Inst File Pointer for
     289           ; Institution IEN (and get its internal value)
     290           N DIV S DIV=$$GET1^DIQ(44,BSDXSC_",","3.5:.07","I")
     291           I DIV="" Q 1 ; If clinic has no division, consider it avial to user.
     292           I DIV=DUZ(2) Q 1 ; If same, then User is in same Div as Clinic
     293           E  Q 0 ; Otherwise, no
     294           QUIT
    294295INDIV2(BSDXRES) ; PEP - Is Resource in the same DUZ(2) as user?
    295         ; Input BSDXRES - BSDX RESOURCE IEN
    296         ; Output: True of False
    297         Q $$INDIV($P($G(^BSDXRES(BSDXRES,0)),U,4)) ; Extract Hospital Location and send to $$INDIV
    298 UTINDIV ; Unit Test $$INDIV
    299         W "Testing if they are the same",!
    300         S DUZ(2)=67
    301         I '$$INDIV(1) W "ERROR",!
    302         I '$$INDIV(2) W "ERROR",!
    303         W "Testing if Div not defined in 44, should be true",!
    304         I '$$INDIV(3) W "ERROR",!
    305         W "Testing empty string. Should be true",!
    306         I '$$INDIV("") W "ERROR",!
    307         W "Testing if they are different",!
    308         S DUZ(2)=899
    309         I $$INDIV(1) W "ERROR",!
    310         I $$INDIV(2) W "ERROR",!
    311         QUIT
    312 UTINDIV2        ; Unit Test $$INDIV2
    313         W "Testing if they are the same",!
    314         S DUZ(2)=69
    315         I $$INDIV2(22)'=0 W "ERROR",!
    316         I $$INDIV2(25)'=1 W "ERROR",!
    317         I $$INDIV2(26)'=1 W "ERROR",!
    318         I $$INDIV2(27)'=1 W "ERROR",!
    319         QUIT
    320         ;
     296           ; Input BSDXRES - BSDX RESOURCE IEN
     297           ; Output: True of False
     298           Q $$INDIV($P($G(^BSDXRES(BSDXRES,0)),U,4)) ; Extract Hospital Location and send to $$INDIV
     299UnitTestINDIV   
     300           W "Testing if they are the same",!
     301           S DUZ(2)=67
     302           I '$$INDIV(1) W "ERROR",!
     303           I '$$INDIV(2) W "ERROR",!
     304           W "Testing if Div not defined in 44, should be true",!
     305           I '$$INDIV(3) W "ERROR",!
     306           W "Testing empty string. Should be true",!
     307           I '$$INDIV("") W "ERROR",!
     308           W "Testing if they are different",!
     309           S DUZ(2)=899
     310           I $$INDIV(1) W "ERROR",!
     311           I $$INDIV(2) W "ERROR",!
     312           QUIT
     313UnitTestINDIV2 
     314           W "Testing if they are the same",!
     315           S DUZ(2)=69
     316           I $$INDIV2(22)'=0 W "ERROR",!
     317           I $$INDIV2(25)'=1 W "ERROR",!
     318           I $$INDIV2(26)'=1 W "ERROR",!
     319           I $$INDIV2(27)'=1 W "ERROR",!
     320           QUIT
     321           ;
    321322GETRADEX(BSDXY,DFN,SCIEN)       ; Get All Pending and On Hold Radiology Exams for Patient; RPC EP; UJO/SMH new in v 1.6
    322323        ; RPC: BSDX GET RAD EXAM FOR PT; Return: Global Array
     
    345346        ; Fields 5 = Request Status; 2 = Procedure; 16 = Requested Entered Date Time
    346347        ; Filter Field: First piece is DFN, 5th piece is 3 or 5 (Status of Pending Or Hold); 20th piece is Radiology Location requested
    347         D LIST^DIC(75.1,"","@;5;2;16","P","","","","B","I $P(^(0),U)=DFN&(35[$P(^(0),U,5))&($P(^(0),U,20)=BSDXRLIEN)","","BSDXOUT","BSDXERR")
     348        ;
     349               ;;EHS/MKH,BAH;;UJO*1.0*143;;30/09/2012;; Update [Fix the performance issue in SchedGUI]
     350               ; START OF CODE CHANGES FOR [UJO*1.0*143]
     351               ; Commented old Line
     352               ;D LIST^DIC(75.1,"","@;5;2;16","P","","","","B","I $P(^(0),U)=DFN&(35[$P(^(0),U,5))&($P(^(0),U,20)=BSDXRLIEN)","","BSDXOUT","BSDXERR")
     353               DO FIND^DIC(75.1,"","@;5;2;16","QP",DFN,"","B","IF 35[$PIECE(^(0),U,5)&($PIECE(^(0),U,20)=BSDXRLIEN)","","BSDXOUT","BSDXERR")
     354               ; END OF CODE CHANGES FOR [UJO*1.0*143]
    348355        ;
    349356        IF $DATA(BSDXERR) GOTO END
  • Scheduling/trunk/m/BSDX02.m

    r1481 r1563  
    1 BSDX02  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/6/12 11:09am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     1BSDX02  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 5/16/11 2:47pm
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ;Licensed under LGPL
    44        ; Change Log
     
    3030        S BSDXERR=""
    3131        S BSDXY="^BSDXTMP("_$J_")"
    32         S ^BSDXTMP($J,0)="I00020APPOINTMENTID^D00030START_TIME^D00030END_TIME^D00030CHECKIN^D00030AUXTIME^I00020PATIENTID^T00030PATIENTNAME^T00030RESOURCENAME"
    33         S ^(0)=^(0)_"^I00005NOSHOW^T00020HRN^I00005ACCESSTYPEID^I00005WALKIN^T00250NOTE^T00006SEX^T00040PID^D00030DOB^I00020RADIOLOGY_EXAM"_$C(30)
     32        S ^BSDXTMP($J,0)="I00020APPOINTMENTID^D00030START_TIME^D00030END_TIME^D00030CHECKIN^D00030AUXTIME^I00020PATIENTID^T00030PATIENTNAME^T00030RESOURCENAME^I00005NOSHOW^T00020HRN^I00005ACCESSTYPEID^I00005WALKIN^T00250NOTE^T00006SEX^T00040PID^D00030DOB^I00020RADIOLOGY_EXAM"_$C(30)
    3433        D ^XBKVAR S X="ETRAP^BSDX02",@^%ZOSF("TRAP")
    3534        ;
     
    3837        ; S %DT="T",X=BSDXEND D ^%DT S BSDXEND=Y
    3938        ; I BSDXEND=-1 S ^BSDXTMP($J,1)=$C(31) Q
    40         ;
     39           ;
    4140        S BSDXI=0
    4241        D STRES
  • Scheduling/trunk/m/BSDX03.m

    r1481 r1563  
    11BSDX03  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:14am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ;Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX04.m

    r1481 r1563  
    1 BSDX04  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;  ; 7/6/12 10:55am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     1BSDX04  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;  ; 4/28/11 10:15am
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ; Change Log:
     
    7474        . Q:BSDXRESN=""
    7575        . Q:'$D(^BSDXRES("B",BSDXRESN))
    76         . S BSDXRESD=$O(^BSDXRES("B",BSDXRESN,0))
     76        . S BSDXRESD=$O(^BSDXRES("B",BSDXRESN,0)) 
    7777        . Q:'+BSDXRESD
    7878        . Q:'$D(^BSDXAB("ARSCT",BSDXRESD))
  • Scheduling/trunk/m/BSDX05.m

    r1481 r1563  
    11BSDX05   ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:16am
    2            ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2           ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33           ; Licensed under LGPL
    44           ;
  • Scheduling/trunk/m/BSDX06.m

    r1481 r1563  
    11BSDX06  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:16am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ; Change Log:
  • Scheduling/trunk/m/BSDX07.m

    r1481 r1563  
    1 BSDX07  ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS  ; 7/9/12 4:02pm
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
    3         ; Licensed under LGPL
    4         ;
    5         ; Change Log:
    6         ; UJO/SMH
    7         ; v1.3 July 13 2010 - Add support i18n - Dates input as FM dates, not US.
    8         ; v1.42 Oct 22 2010 - Transaction now restartable by providing arguments
    9         ; v1.42 Oct 30 2010 - Extensive refactoring.
    10         ; v1.5  Mar 15 2011 - End time does not have to have time anymore.
    11         ;      It could be midnight of the next day
    12         ; v1.6 Apr 11 2011 - Support for Scheduling Radiology Exams...
    13         ; v1.7 Jun 20 2012 - Refactoring to remove transactions - many changes
    14         ;                  - AVUPDT moved to AVUPDTMK in BSDXAPI1
    15         ;
    16         ; Error Reference:
    17         ; -1: Patient Record is locked. This means something is wrong!!!!
    18         ; -2: Start Time is not a valid Fileman date
    19         ; -3: End Time is not a valid Fileman date
    20         ; v1.5:obsolete::-4: End Time does not have time inside of it.
    21         ; -5: BSDXPATID is not numeric
    22         ; -6: Patient Does not exist in ^DPT
    23         ; -7: Resource Name does not exist in B index of BSDX RESOURCE
    24         ; -8: Resouce doesn't exist in ^BSDXRES
    25         ; -9: Couldn't add appointment to BSDX APPOINTMENT
    26         ; -10: Couldn't add appointment to files 2 and/or 44
    27         ; -100: Mumps Error
    28         ;
     1BSDX07  ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS  ; 4/28/11 10:17am
     2           ;;1.6;BSDX;;Aug 31, 2011;Build 25
     3           ; Licensed under LGPL
     4           ;
     5           ; Change Log:
     6           ; UJO/SMH
     7           ; v1.3 July 13 2010 - Add support i18n - Dates input as FM dates, not US.
     8           ; v1.42 Oct 22 2010 - Transaction now restartable by providing arguments
     9           ;   thanks to Rick Marshall and Zach Gonzalez at Oroville.
     10           ; v1.42 Oct 30 2010 - Extensive refactoring.
     11           ; v1.5  Mar 15 2011 - End time does not have to have time anymore.
     12           ;      It could be midnight of the next day
     13           ; v1.6 Apr 11 2011 - Support for Scheduling Radiology Exams...
     14           ;
     15           ; Error Reference:
     16           ; -1: Patient Record is locked. This means something is wrong!!!!
     17           ; -2: Start Time is not a valid Fileman date
     18           ; -3: End Time is not a valid Fileman date
     19           ; v1.5:obsolete::-4: End Time does not have time inside of it.
     20           ; -5: BSDXPATID is not numeric
     21           ; -6: Patient Does not exist in ^DPT
     22           ; -7: Resource Name does not exist in B index of BSDX RESOURCE
     23           ; -8: Resouce doesn't exist in ^BSDXRES
     24           ; -9: Couldn't add appointment to BSDX APPOINTMENT
     25           ; -10: Couldn't add appointment to files 2 and/or 44
     26           ; -100: Mumps Error
     27       
    2928APPADDD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)       ;EP
    30         ;Entry point for debugging
    31         ; D DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)")
    32         Q
    33         ;
    34 APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXRADEXAM) ;Private EP
    35         ;
    36         ;Called by RPC: BSDX ADD NEW APPOINTMENT
    37         ;
    38         ;Add new appointment to 3 files
    39         ; - BSDX APPOINTMENT
    40         ; - Hosp Location Appointment SubSubfile if Resource is linked to clinic
    41         ; - Patient Appointment Subfile if Resource is linked to clinic
    42         ;
    43         ;Paramters:
    44         ;BSDXY: Global Return (RPC must be set to Global Array)
    45         ;BSDXSTART: FM Start Date
    46         ;BSDXEND: FM End Date
    47         ;BSDXPATID: Patient DFN
    48         ;BSDXRES is ResourceName in BSDX RESOURCE file (not IEN)
    49         ;BSDXLEN is the appointment duration in minutes
    50         ;BSDXNOTE is the Appiontment Note
    51         ;BSDXATID is used for 2 purposes:
    52         ; if BSDXATID = "WALKIN" then BSDAPI is called to create a walkin appt.
    53         ; if BSDXATID = a number, then it is the access type id (used for rebooking)
    54         ;BSDXRADEXAM is used to store the Radiology Exam to which this appointment is tied to (optional)
    55         ;
    56         ;Return:
    57         ; ADO.net Recordset having fields:
    58         ; AppointmentID and ErrorNumber
    59         ;
    60         ; TODO: Specifying BSDXLEN and BSDXEND is redundant. For future programmers
    61         ; to sort out. Needs changes on client.
    62         ;
    63         ;Test lines:
    64         ;BSDX ADD NEW APPOINTMENT^3091122.0930^3091122.1000^370^Dr Office^30^EXAM^WALKIN
    65         ;
    66         ; Deal with optional arguments
    67         S BSDXRADEXAM=$G(BSDXRADEXAM)
    68         ;
    69         ; Return Array; set Return and clear array
    70         S BSDXY=$NA(^BSDXTMP($J))
    71         K ^BSDXTMP($J)
    72         ;
    73         ; $ET
    74         N $ET S $ET="G ETRAP^BSDX07"
    75         ;
    76         ; Counter
    77         N BSDXI S BSDXI=0
    78         ;
    79         ; Lock BSDX node, only to synchronize access to the globals.
    80         ; It's not expected that the error will ever happen as no filing
    81         ; is supposed to take 5 seconds.
    82         L +^BSDXPAT(BSDXPATID):5 I '$T D ERR(BSDXI,"-1~Patient record is locked. Please contact technical support.") Q
    83         ;
    84         ; Header Node
    85         S ^BSDXTMP($J,BSDXI)="I00020APPOINTMENTID^T00100ERRORID"_$C(30)
    86         ;
    87         ; Turn off SDAM APPT PROTOCOL BSDX Entries
    88         N BSDXNOEV
    89         S BSDXNOEV=1 ;Don't execute BSDX ADD APPOINTMENT protocol
    90         ;
    91         ; Set Error Message to be empty
    92         N BSDXERR S BSDXERR=0
    93         ;
    94         ;;;test for error. See if %ZTER works
    95         I $G(BSDXDIE) N X S X=1/0
    96         ;;;test
    97         ;
    98         ; -- Start and End Date Processing --
    99         ; If C# sends the dates with extra zeros, remove them
    100         S BSDXSTART=+BSDXSTART,BSDXEND=+BSDXEND
    101         ; Are the dates valid? Must be FM Dates > than 2010
    102         I BSDXSTART'>3100000 D ERR(BSDXI,"-2~BSDX07 Error: Invalid Start Time") Q
    103         I BSDXEND'>3100000 D ERR(BSDXI,"-3~BSDX07 Error: Invalid End Time") Q
    104         ;
    105         ;; If Ending date doesn't have a time, this is an error --rm 1.5
    106         ; I $L(BSDXEND,".")=1 D ERR(BSDXI,"-4~BSDX07 Error: Invalid End Time") Q
    107         ;
    108         ; If the Start Date is greater than the end date, swap dates
    109         N BSDXTMP
    110         I BSDXSTART>BSDXEND S BSDXTMP=BSDXEND,BSDXEND=BSDXSTART,BSDXSTART=BSDXTMP
    111         ;
    112         ; Check if the patient exists:
    113         ; - DFN valid number?
    114         ; - Valid Patient in file 2?
    115         I '+BSDXPATID D ERR(BSDXI,"-5~BSDX07 Error: Invalid Patient ID") Q
    116         I '$D(^DPT(BSDXPATID,0)) D ERR(BSDXI,"-6~BSDX07 Error: Invalid Patient ID") Q
    117         ;
    118         ;Validate Resource entry
    119         I '$D(^BSDXRES("B",BSDXRES)) D ERR(BSDXI,"-7~BSDX07 Error: Invalid Resource ID") Q
    120         N BSDXRESD ; Resource IEN
    121         S BSDXRESD=$O(^BSDXRES("B",BSDXRES,0))
    122         N BSDXRNOD ; Resouce zero node
    123         S BSDXRNOD=$G(^BSDXRES(BSDXRESD,0))
    124         I BSDXRNOD="" D ERR(BSDXI,"-8~BSDX07 Error: invalid Resource entry.") Q
    125         ;
    126         ; Walk-in (Unscheduled) Appointment?
    127         N BSDXWKIN S BSDXWKIN=0
    128         I BSDXATID="WALKIN" S BSDXWKIN=1
    129         ; Reset Access Type ID if it doesn't say "WALKIN" and isn't a number
    130         I BSDXATID'?.N&(BSDXATID'="WALKIN") S BSDXATID=""
    131         ;
    132         ; Now, check if PIMS has any issues with us making the appt using MAKECK
    133         N BSDXSCD S BSDXSCD=$P(BSDXRNOD,U,4)  ; Hosp Location IEN
    134         N BSDXERR S BSDXERR=0 ; Variable to hold value of $$MAKE and $$MAKECK
    135         N BSDXC ; Array to send to MAKE and MAKECK APIs
    136         ; Only if we have a valid Hosp Location
    137         I +BSDXSCD,$D(^SC(BSDXSCD,0)) D
    138         . S BSDXC("PAT")=BSDXPATID
    139         . S BSDXC("CLN")=BSDXSCD
    140         . S BSDXC("TYP")=3 ;3 for scheduled appts, 4 for walkins
    141         . S:BSDXWKIN BSDXC("TYP")=4
    142         . S BSDXC("ADT")=BSDXSTART
    143         . S BSDXC("LEN")=BSDXLEN
    144         . S BSDXC("OI")=$E($G(BSDXNOTE),1,150) ;File 44 has 150 character limit on OTHER field
    145         . S BSDXC("OI")=$TR(BSDXC("OI"),";"," ") ;No semicolons allowed by MAKE^BSDXAPI
    146         . S BSDXC("OI")=$$STRIP(BSDXC("OI")) ;Strip control characters from note
    147         . S BSDXC("USR")=DUZ
    148         . S BSDXERR=$$MAKECK^BSDXAPI(.BSDXC)
    149         I BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: MAKECK^BSDXAPI returned error code: "_BSDXERR) Q  ; no need for roll back
    150         ;
    151         ; Done with all checks, let's make appointment in BSDX APPOINTMENT
    152         N BSDXAPPTID
    153         S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM)
    154         I 'BSDXAPPTID D ERR(BSDXI,"-9~BSDX07 Error: Unable to add appointment to BSDX APPOINTMENT file.") Q  ; no roll back needed! No appts made.
    155         I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE) ; no error checks are made here
    156         ; I don't think it's important b/c users can detect right away if the WP
    157         ; filing fails.
    158         ;
    159         I $G(BSDXSIMERR1) D ERR(BSDXI,"-11~BSDX07 Error: Simulated Error"),ROLLBACK(BSDXAPPTID,.BSDXC) Q  ; UT Line
    160         ;
    161         ; Only if we have a valid Hosp Loc can we make an appointment in 2/44
    162         ; Use BSDXC array from before.
    163         ; FYI: $$MAKE itself calls $$MAKECK to check again for being okay.
    164         ; If an error happens here, we roll back both ^BSDXAPPT and 2/44 by deleting
    165         N BSDXERR S BSDXERR=0 ; Variable to hold value of $$MAKE and $$MAKECK
    166         I +BSDXSCD,$D(^SC(BSDXSCD,0)) S BSDXERR=$$MAKE^BSDXAPI(.BSDXC)
    167         I BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: MAKE^BSDXAPI returned error code: "_BSDXERR),ROLLBACK(BSDXAPPTID,.BSDXC) Q
    168         ;
    169         ; Unlock
    170         L -^BSDXPAT(BSDXPATID)
    171         ;
    172         ;Return Recordset
    173         S BSDXI=BSDXI+1
    174         S ^BSDXTMP($J,BSDXI)=BSDXAPPTID_"^"_$C(30)
    175         S BSDXI=BSDXI+1
    176         S ^BSDXTMP($J,BSDXI)=$C(31)
    177         Q
     29           ;Entry point for debugging
     30           D DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)")
     31           Q
     32           ;
     33UT      ; Unit Tests
     34           N ZZZ
     35           ; Test for bad start date
     36           D APPADD(.ZZZ,2100123,3100123.3,2,"Dr Office",30,"Sam's Note",1)
     37           I +$P(^BSDXTMP($J,1),U,2)'=-2 W "Error in -2",!
     38           ; Test for bad end date
     39           D APPADD(.ZZZ,3100123,2100123.3,2,"Dr Office",30,"Sam's Note",1)
     40           I +$P(^BSDXTMP($J,1),U,2)'=-3 W "Error in -3",!
     41           ; Test for end date without time
     42           D APPADD(.ZZZ,3100123.1,3100123,2,"Dr Office",30,"Sam's Note",1)
     43           I +$P(^BSDXTMP($J,1),U,2)'=-4 W "Error in -4",!
     44           ; Test for mumps error
     45           S bsdxdie=1
     46           D APPADD(.ZZZ,3100123.09,3100123.093,2,"Dr Office",30,"Sam's Note",1)
     47           I +$P(^BSDXTMP($J,1),U,2)'=-100 W "Error in -100: M Error",!
     48           K bsdxdie
     49           ; Test for TRESTART
     50           s bsdxrestart=1
     51           D APPADD(.ZZZ,3100123.09,3100123.093,3,"Dr Office",30,"Sam's Note",1)
     52           I +$P(^BSDXTMP($J,1),U,2)'=0&(+$P(^BSDXTMP($J,1),U,2)'=-10) W "Error in TRESTART",!
     53           k bsdxrestart
     54           ; Test for non-numeric patient
     55           D APPADD(.ZZZ,3100123.09,3100123.093,"CAT,DOG","Dr Office",30,"Sam's Note",1)
     56           I +$P(^BSDXTMP($J,1),U,2)'=-5 W "Error in -5",!
     57           ; Test for a non-existent patient
     58           D APPADD(.ZZZ,3100123.09,3100123.093,8989898989,"Dr Office",30,"Sam's Note",1)
     59           I +$P(^BSDXTMP($J,1),U,2)'=-6 W "Error in -6",!
     60           ; Test for a non-existent resource name
     61           D APPADD(.ZZZ,3100123.09,3100123.093,3,"lkajsflkjsadf",30,"Sam's Note",1)
     62           I +$P(^BSDXTMP($J,1),U,2)'=-7 W "Error in -7",!
     63           ; Test for corrupted resource
     64           ; Can't test for -8 since it requires DB corruption
     65           ; Test for inability to add appointment to BSDX Appointment
     66           ; Also requires something wrong in the DB
     67           ; Test for inability to add appointment to 2,44
     68           ; Test by creating a duplicate appointment
     69           D APPADD(.ZZZ,3100123.09,3100123.093,3,"Dr Office",30,"Sam's Note",1)
     70           D APPADD(.ZZZ,3100123.09,3100123.093,3,"Dr Office",30,"Sam's Note",1)
     71           I +$P(^BSDXTMP($J,1),U,2)'=-10 W "Error in -10",!
     72           ; Test for normality:
     73           D APPADD(.ZZZ,3110123.09,3110123.093,3,"Dr Office",30,"Sam's Note",1)
     74           ; Does Appt exist?
     75           N APPID S APPID=+$P(^BSDXTMP($J,1),U)
     76           I 'APPID W "Error Making Appt-1" QUIT
     77           I +^BSDXAPPT(APPID,0)'=3110123.09 W "Error Making Appt-2"
     78           I '$D(^DPT(3,"S",3110123.09)) W "Error Making Appt-3"
     79           I '$D(^SC(2,"S",3110123.09)) W "Error Making Appt-4"
     80           QUIT
     81           ;
     82APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXRADEXAM) ;EP
     83           ;
     84           ;Called by RPC: BSDX ADD NEW APPOINTMENT
     85           ;
     86           ;Add new appointment to 3 files
     87           ; - BSDX APPOINTMENT
     88           ; - Hosp Location Appointment SubSubfile if Resource is linked to clinic
     89           ; - Patient Appointment Subfile if Resource is linked to clinic
     90           ;
     91           ;Paramters:
     92           ;BSDXY: Global Return (RPC must be set to Global Array)
     93           ;BSDXSTART: FM Start Date
     94           ;BSDXEND: FM End Date
     95           ;BSDXPATID: Patient DFN
     96           ;BSDXRES is ResourceName in BSDX RESOURCE file (not IEN)
     97           ;BSDXLEN is the appointment duration in minutes
     98           ;BSDXNOTE is the Appiontment Note
     99           ;BSDXATID is used for 2 purposes:
     100           ; if BSDXATID = "WALKIN" then BSDAPI is called to create a walkin appt.
     101           ; if BSDXATID = a number, then it is the access type id (used for rebooking)
     102           ;BSDXRADEXAM is used to store the Radiology Exam to which this appointment is tied to (optional)
     103           ;
     104           ;Return:
     105           ; ADO.net Recordset having fields:
     106           ; AppointmentID and ErrorNumber
     107           ;
     108           ;Test lines:
     109           ;BSDX ADD NEW APPOINTMENT^3091122.0930^3091122.1000^370^Dr Office^30^EXAM^WALKIN
     110           ;
     111           ; Deal with optional arguments
     112           S BSDXRADEXAM=$G(BSDXRADEXAM)
     113           ; Return Array; set Return and clear array
     114           S BSDXY=$NA(^BSDXTMP($J))
     115           K ^BSDXTMP($J)
     116           ; $ET
     117           N $ET S $ET="G ETRAP^BSDX07"
     118           ; Counter
     119           N BSDXI S BSDXI=0
     120           ; Lock BSDX node, only to synchronize access to the globals.
     121           ; It's not expected that the error will ever happen as no filing
     122           ; is supposed to take 5 seconds.
     123           L +^BSDXAPPT(BSDXPATID):5 I '$T D ERR(BSDXI,"-1~Patient record is locked. Please contact technical support.") Q
     124           ; Header Node
     125           S ^BSDXTMP($J,BSDXI)="I00020APPOINTMENTID^T00100ERRORID"_$C(30)
     126           ;Restartable Transaction; restore paramters when starting.
     127           ; (Params restored are what's passed here + BSDXI)
     128           TSTART (BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXI):T="BSDX ADD NEW APPOINTMENT^BSDX07"
     129           ;
     130           ; Turn off SDAM APPT PROTOCOL BSDX Entries
     131           N BSDXNOEV
     132           S BSDXNOEV=1 ;Don't execute BSDX ADD APPOINTMENT protocol
     133           ;
     134           ; Set Error Message to be empty
     135           N BSDXERR S BSDXERR=0
     136           ;
     137           ;;;test for error inside transaction. See if %ZTER works
     138           I $G(bsdxdie) S X=1/0
     139           ;;;test
     140           ;;;test for TRESTART
     141           I $G(bsdxrestart) K bsdxrestart TRESTART
     142           ;;;test
     143           ;
     144           ; -- Start and End Date Processing --
     145           ; If C# sends the dates with extra zeros, remove them
     146           S BSDXSTART=+BSDXSTART,BSDXEND=+BSDXEND
     147           ; Are the dates valid? Must be FM Dates > than 2010
     148           I BSDXSTART'>3100000 D ERR(BSDXI,"-2~BSDX07 Error: Invalid Start Time") Q
     149           I BSDXEND'>3100000 D ERR(BSDXI,"-3~BSDX07 Error: Invalid End Time") Q
     150           ;
     151           ;; If Ending date doesn't have a time, this is an error --rm 1.5
     152           ; I $L(BSDXEND,".")=1 D ERR(BSDXI,"-4~BSDX07 Error: Invalid End Time") Q
     153           ;
     154           ; If the Start Date is greater than the end date, swap dates
     155           N BSDXTMP
     156           I BSDXSTART>BSDXEND S BSDXTMP=BSDXEND,BSDXEND=BSDXSTART,BSDXSTART=BSDXTMP
     157           ;
     158           ; Check if the patient exists:
     159           ; - DFN valid number?
     160           ; - Valid Patient in file 2?
     161           I '+BSDXPATID D ERR(BSDXI,"-5~BSDX07 Error: Invalid Patient ID") Q
     162           I '$D(^DPT(BSDXPATID,0)) D ERR(BSDXI,"-6~BSDX07 Error: Invalid Patient ID") Q
     163           ;
     164           ;Validate Resource entry
     165           I '$D(^BSDXRES("B",BSDXRES)) D ERR(BSDXI,"-7~BSDX07 Error: Invalid Resource ID") Q
     166           N BSDXRESD ; Resource IEN
     167           S BSDXRESD=$O(^BSDXRES("B",BSDXRES,0))
     168           N BSDXRNOD ; Resouce zero node
     169           S BSDXRNOD=$G(^BSDXRES(BSDXRESD,0))
     170           I BSDXRNOD="" D ERR(BSDXI,"-8~BSDX07 Error: invalid Resource entry.") Q
     171           ;
     172           ; Walk-in (Unscheduled) Appointment?
     173           N BSDXWKIN S BSDXWKIN=0
     174           I BSDXATID="WALKIN" S BSDXWKIN=1
     175           ; Reset Access Type ID if it doesn't say "WALKIN" and isn't a number
     176           I BSDXATID'?.N&(BSDXATID'="WALKIN") S BSDXATID=""
     177           ;
     178           ; Done with all checks, let's make appointment in BSDX APPOINTMENT
     179           N BSDXAPPTID
     180           S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM)
     181           I 'BSDXAPPTID D ERR(BSDXI,"-9~BSDX07 Error: Unable to add appointment to BSDX APPOINTMENT file.") Q
     182           I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
     183           ;
     184           ; Then Create Subfiles in 2/44 Appointment
     185           N BSDXSCD S BSDXSCD=$P(BSDXRNOD,U,4)  ; Hosp Location IEN
     186           ; Only if we have a valid Hosp Loc can we make an appointment
     187           I +BSDXSCD,$D(^SC(BSDXSCD,0)) D  I +BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: MAKE^BSDXAPI returned error code: "_BSDXERR) Q
     188           . N BSDXC
     189           . S BSDXC("PAT")=BSDXPATID
     190           . S BSDXC("CLN")=BSDXSCD
     191           . S BSDXC("TYP")=3 ;3 for scheduled appts, 4 for walkins
     192           . S:BSDXWKIN BSDXC("TYP")=4
     193           . S BSDXC("ADT")=BSDXSTART
     194           . S BSDXC("LEN")=BSDXLEN
     195           . S BSDXC("OI")=$E($G(BSDXNOTE),1,150) ;File 44 has 150 character limit on OTHER field
     196           . S BSDXC("OI")=$TR(BSDXC("OI"),";"," ") ;No semicolons allowed by MAKE^BSDXAPI
     197           . S BSDXC("OI")=$$STRIP(BSDXC("OI")) ;Strip control characters from note
     198           . S BSDXC("USR")=DUZ
     199           . S BSDXERR=$$MAKE^BSDXAPI(.BSDXC)
     200           . Q:BSDXERR
     201           . ;Update RPMS Clinic availability
     202           . D AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)
     203           . Q
     204           ;
     205           ;Return Recordset
     206           TCOMMIT
     207           L -^BSDXAPPT(BSDXPATID)
     208           S BSDXI=BSDXI+1
     209           S ^BSDXTMP($J,BSDXI)=BSDXAPPTID_"^"_$C(30)
     210           S BSDXI=BSDXI+1
     211           S ^BSDXTMP($J,BSDXI)=$C(31)
     212           Q
     213BSDXDEL(BSDXAPPTID)     ;Deletes appointment BSDXAPPTID from BSDXAPPOINTMETN
     214           N DA,DIK
     215           S DIK="^BSDXAPPT(",DA=BSDXAPPTID
     216           D ^DIK
     217           Q
     218           ;
    178219STRIP(BSDXZ)       ;Replace control characters with spaces
    179         N BSDXI
    180         F BSDXI=1:1:$L(BSDXZ) I (32>$A($E(BSDXZ,BSDXI))) S BSDXZ=$E(BSDXZ,1,BSDXI-1)_" "_$E(BSDXZ,BSDXI+1,999)
    181         Q BSDXZ
    182         ;
     220           N BSDXI
     221           F BSDXI=1:1:$L(BSDXZ) I (32>$A($E(BSDXZ,BSDXI))) S BSDXZ=$E(BSDXZ,1,BSDXI-1)_" "_$E(BSDXZ,BSDXI+1,999)
     222           Q BSDXZ
     223           ;
    183224BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM)       ;ADD BSDX APPOINTMENT ENTRY
    184         ;Returns ien in BSDXAPPT or 0 if failed
    185         ;Create entry in BSDX APPOINTMENT
    186         N BSDXAPPTID,BSDXFDA
    187         S BSDXFDA(9002018.4,"+1,",.01)=BSDXSTART
    188         S BSDXFDA(9002018.4,"+1,",.02)=BSDXEND
    189         S BSDXFDA(9002018.4,"+1,",.05)=BSDXPATID
    190         S BSDXFDA(9002018.4,"+1,",.07)=BSDXRESD
    191         S BSDXFDA(9002018.4,"+1,",.08)=$G(DUZ)
    192         S BSDXFDA(9002018.4,"+1,",.09)=$$NOW^XLFDT
    193         S:BSDXATID="WALKIN" BSDXFDA(9002018.4,"+1,",.13)="y"
    194         S:BSDXATID?.N BSDXFDA(9002018.4,"+1,",.06)=BSDXATID
    195         S BSDXFDA(9002018.4,"+1,",.14)=$G(BSDXRADEXAM)
    196         N BSDXIEN,BSDXMSG
    197         D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
    198         S BSDXAPPTID=+$G(BSDXIEN(1))
    199         Q BSDXAPPTID
    200         ;
     225           ;Returns ien in BSDXAPPT or 0 if failed
     226           ;Create entry in BSDX APPOINTMENT
     227           N BSDXAPPTID
     228           S BSDXFDA(9002018.4,"+1,",.01)=BSDXSTART
     229           S BSDXFDA(9002018.4,"+1,",.02)=BSDXEND
     230           S BSDXFDA(9002018.4,"+1,",.05)=BSDXPATID
     231           S BSDXFDA(9002018.4,"+1,",.07)=BSDXRESD
     232           S BSDXFDA(9002018.4,"+1,",.08)=$G(DUZ)
     233           S BSDXFDA(9002018.4,"+1,",.09)=$$NOW^XLFDT
     234           S:BSDXATID="WALKIN" BSDXFDA(9002018.4,"+1,",.13)="y"
     235           S:BSDXATID?.N BSDXFDA(9002018.4,"+1,",.06)=BSDXATID
     236           S BSDXFDA(9002018.4,"+1,",.14)=BSDXRADEXAM
     237           N BSDXIEN,BSDXMSG
     238           D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
     239           S BSDXAPPTID=+$G(BSDXIEN(1))
     240           Q BSDXAPPTID
     241           ;
    201242BSDXWP(BSDXAPPTID,BSDXNOTE)     ;
    202         ;Add WP field
    203         N BSDXMSG
    204         I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE=""
    205         I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0)
    206         I $D(BSDXNOTE(.5)) D
    207         . D WP^DIE(9002018.4,BSDXAPPTID_",",1,"","BSDXNOTE","BSDXMSG")
    208         Q
    209         ;
     243           ;Add WP field
     244           I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE=""
     245           I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0)
     246           I $D(BSDXNOTE(.5)) D
     247           . D WP^DIE(9002018.4,BSDXAPPTID_",",1,"","BSDXNOTE","BSDXMSG")
     248           Q
     249           ;
    210250ADDEVT(BSDXPATID,BSDXSTART,BSDXSC,BSDXSCDA)     ;EP
    211         ;Called by BSDX ADD APPOINTMENT protocol
    212         ;BSDXSC=IEN of clinic in ^SC
    213         ;BSDXSCDA=IEN for ^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA). Use to get Length & Note
    214         ;
    215         N BSDXNOD,BSDXLEN,BSDXAPPTID,BSDXNODP,BSDXWKIN,BSDXRES,BSDXNOTE,BSDXEND
    216         Q:+$G(BSDXNOEV)
    217         I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0))
    218         E  I $D(^BSDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0))
    219         Q:'+$G(BSDXRES)
    220         S BSDXNOD=$G(^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA,0))
    221         Q:BSDXNOD=""
    222         S BSDXNODP=$G(^DPT(BSDXPATID,"S",BSDXSTART,0))
    223         S BSDXWKIN=""
    224         S:$P(BSDXNODP,U,7)=4 BSDXWKIN="WALKIN" ;Purpose of Visit field of DPT Appointment subfile
    225         S BSDXLEN=$P(BSDXNOD,U,2)
    226         Q:'+BSDXLEN
    227         S BSDXEND=$$FMADD^XLFDT(BSDXSTART,0,0,BSDXLEN,0)
    228         S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXWKIN)
    229         Q:'+BSDXAPPTID
    230         S BSDXNOTE=$P(BSDXNOD,U,4)
    231         I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
    232         D ADDEVT3(BSDXRES)
    233         Q
    234         ;
     251           ;Called by BSDX ADD APPOINTMENT protocol
     252           ;BSDXSC=IEN of clinic in ^SC
     253           ;BSDXSCDA=IEN for ^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA). Use to get Length & Note
     254           ;
     255           N BSDXNOD,BSDXLEN,BSDXAPPTID,BSDXNODP,BSDXWKIN,BSDXRES
     256           Q:+$G(BSDXNOEV)
     257           I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0))
     258           E  I $D(^BSDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0))
     259           Q:'+$G(BSDXRES)
     260           S BSDXNOD=$G(^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA,0))
     261           Q:BSDXNOD=""
     262           S BSDXNODP=$G(^DPT(BSDXPATID,"S",BSDXSTART,0))
     263           S BSDXWKIN=""
     264           S:$P(BSDXNODP,U,7)=4 BSDXWKIN="WALKIN" ;Purpose of Visit field of DPT Appointment subfile
     265           S BSDXLEN=$P(BSDXNOD,U,2)
     266           Q:'+BSDXLEN
     267           S BSDXEND=$$FMADD^XLFDT(BSDXSTART,0,0,BSDXLEN,0)
     268           S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXWKIN)
     269           Q:'+BSDXAPPTID
     270           S BSDXNOTE=$P(BSDXNOD,U,4)
     271           I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
     272           D ADDEVT3(BSDXRES)
     273           Q
     274           ;
    235275ADDEVT3(BSDXRES)           ;
    236         ;Call RaiseEvent to notify GUI clients
    237         N BSDXRESN
    238         S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
    239         Q:BSDXRESN=""
    240         S BSDXRESN=$P(BSDXRESN,"^")
    241         ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
    242         D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
    243         Q
    244         ;
    245 ROLLBACK(BSDXAPPTID,BSDXC)      ; Private EP; Roll back appointment set
    246         ; DO NOT USE except as an emergency measure - only if unforseen error occurs
    247         ; Input:
    248         ; Appointment ID to remove from ^BSDXAPPT
    249         ; BSDXC array (see array format in $$MAKE^BSDXAPI)
    250         N %
    251         D BSDXDEL^BSDX07(BSDXAPPTID)
    252         S:$D(BSDXC) %=$$UNMAKE^BSDXAPI(.BSDXC) ; rtn value always 0
    253         QUIT
    254         ;
    255 BSDXDEL(BSDXAPPTID)     ;Private EP ; Deletes appointment BSDXAPPTID from ^BSDXAPPT
    256         ; DO NOT USE except in emergencies to roll back an appointment set
    257         N DA,DIK
    258         S DIK="^BSDXAPPT(",DA=BSDXAPPTID
    259         D ^DIK
    260         Q
    261         ;
    262 ERR(BSDXI,BSDXERR)       ;Error processing - different from error trap.
    263         ; Unlock first
    264         L -^BSDXPAT(BSDXPATID)
    265         ; If last line is $C(31), we are done. No more errors to send to client.
    266         I ^BSDXTMP($J,$O(^BSDXTMP($J," "),-1))=$C(31) QUIT
    267         S BSDXI=BSDXI+1
    268         S BSDXERR=$TR(BSDXERR,"^","~")
    269         S ^BSDXTMP($J,BSDXI)="0^"_BSDXERR_$C(30)
    270         S BSDXI=BSDXI+1
    271         S ^BSDXTMP($J,BSDXI)=$C(31)
    272         Q
    273         ;
     276           ;Call RaiseEvent to notify GUI clients
     277           N BSDXRESN
     278           S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
     279           Q:BSDXRESN=""
     280           S BSDXRESN=$P(BSDXRESN,"^")
     281           ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
     282           D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
     283           Q
     284           ;
     285ERR(BSDXI,BSDXERR)       ;Error processing
     286           S BSDXI=BSDXI+1
     287           S BSDXERR=$TR(BSDXERR,"^","~")
     288           I $TL>0 TROLLBACK
     289           S ^BSDXTMP($J,BSDXI)="0^"_BSDXERR_$C(30)
     290           S BSDXI=BSDXI+1
     291           S ^BSDXTMP($J,BSDXI)=$C(31)
     292           L -^BSDXAPPT(BSDXPATID)
     293           Q
     294           ;
    274295ETRAP     ;EP Error trap entry
    275         N $ET S $ET="D ^%ZTER HALT"  ; Emergency Error Trap
    276         D ^%ZTER
    277         ;
    278         I +$G(BSDXAPPTID) D ROLLBACK(BSDXAPPTID,.BSDXC) ; Rollback if BSDXAPPTID exists
    279         ;
    280         ; Log error message and send to client
    281         I '$D(BSDXI) N BSDXI S BSDXI=0
    282         D ERR(BSDXI,"-100~BSDX07 Error: "_$G(%ZTERZE))
    283         Q:$Q 1_U_"Mumps Error" Q
    284         ;
     296           N $ET S $ET="D ^%ZTER HALT"  ; Emergency Error Trap
     297           ; Rollback, otherwise ^XTER will be empty from future rollback
     298           I $TL>0 TROLLBACK
     299           D ^%ZTER
     300           S $EC=""  ; Clear Error
     301           ; Log error message and send to client
     302           I '$D(BSDXI) N BSDXI S BSDXI=0
     303           D ERR(BSDXI,"-100~BSDX07 Error: "_$G(%ZTERZE))
     304           Q
     305           ;
     306DAY     ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
     307           ;
     308DOW     S %=$E(X,1,3),Y=$E(X,4,5),Y=Y>2&'(%#4)+$E("144025036146",Y)
     309           F %=%:-1:281 S Y=%#4=1+1+Y
     310           S Y=$E(X,6,7)+Y#7
     311           Q
     312           ;
     313AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)         ;Update RPMS Clinic availability
     314           ;SEE SDM1
     315           N Y,DFN
     316           N SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG
     317           N X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I
     318           S Y=BSDXSCD,DFN=BSDXPATID
     319           S SL=$G(^SC(+Y,"SL")),X=$P(SL,U,3),STARTDAY=$S($L(X):X,1:8),SC=Y,SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X=1:X,X:X,1:4),SI=$S(X="":4,X<3:4,X:X,1:4),STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz",SDDIF=$S(HSI<3:8/HSI,1:2) K Y
     320           ;Determine maximum days for scheduling
     321           S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
     322           S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
     323           S SDDATE=BSDXSTART
     324           S SDSDATE=SDDATE,SDDATE=SDDATE\1
     3251         ;L  Q:$D(SDXXX)  S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0  S SC=+SC
     326           Q:$D(SDXXX)  S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0  S SC=+SC
     327           S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)
     328           S X2=SDEDT D C^%DTC S SDEDT=X
     329           S Y=BSDXSTART
     330EN1     S (X,SD)=Y,SM=0 D DOW
     331S         I '$D(^SC(SC,"ST",$P(SD,"."),1)) S SS=+$O(^SC(+SC,"T"_Y,SD)) Q:SS'>0  Q:^(SS,1)=""  S ^SC(+SC,"ST",$P(SD,"."),1)=$E($P($T(DAY),U,Y+2),1,2)_" "_$E(SD,6,7)_$J("",SI+SI-6)_^(1),^(0)=$P(SD,".")
     332           S S=BSDXLEN
     333           ;Check if BSDXLEN evenly divisible by appointment length
     334           S RPMSL=$P(SL,U)
     335           I BSDXLEN<RPMSL S BSDXLEN=RPMSL
     336           I BSDXLEN#RPMSL'=0 D
     337           . S BSDXINC=BSDXLEN\RPMSL
     338           . S BSDXINC=BSDXINC+1
     339           . S BSDXLEN=RPMSL*BSDXINC
     340           S SL=S_U_$P(SL,U,2,99)
     341SC       S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) Q:SDLOCK>9
     342           L +^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC
     343           S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1)
     344           S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
     345           I (I<1!'$F(S,"["))&(S'["CAN") L -^SC(SC,"ST",$P(SD,"."),1) Q
     346           I SM<7 S %=$F(S,"[",SS-1) S:'%!($P(SL,"^",6)<3) %=999 I $F(S,"]",SS)'<%!(SDDIF=2&$E(S,ST+ST+1,SS-1)["[") S SM=7
     347           ;
     348SP       I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP
     349           S SDNOT=1
     350           S ABORT=0
     351           F I=ST+ST:SDDIF:SS-SDDIF D  Q:ABORT
     352           . S ST=$E(S,I+1) S:ST="" ST=" "
     353           . S Y=$E(STR,$F(STR,ST)-2)
     354           . I S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))) S ABORT=1 Q
     355           . I Y="" S ABORT=1 Q
     356           . S:Y'?1NL&(SM<6) SM=6 S ST=$E(S,I+2,999) S:ST="" ST=" " S S=$E(S,1,I)_Y_ST
     357           . Q
     358           S ^SC(SC,"ST",$P(SD,"."),1)=S
     359           L -^SC(SC,"ST",$P(SD,"."),1)
     360           Q
  • Scheduling/trunk/m/BSDX08.m

    r1481 r1563  
    1 BSDX08  ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 7/9/12 4:22pm
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     1BSDX08  ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 4/28/11 10:17am
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ;
    44        ; Original by HMW. New Written by Sam Habiel. Licensed under LGPL.
     
    66        ; Change History
    77        ; 3101022 UJO/SMH v1.42
    8         ;  - Transaction work. As of v 1.7, all work here has been superceded
    9         ;  - Refactoring of AVUPDT - never tested though.
     8        ;  - Transaction now restartable. Thanks to
     9        ;   --> Zach Gonzalez and Rick Marshall for fix.
     10        ;  - Extra TROLLBACK in Lock Statement when lock fails.
     11        ;   --> Removed--Rollback is already in ERR tag.
     12        ;  - Added new statements to old SD code in AVUPDT to obviate
     13        ;   --> need to restore variables in transaction
     14        ;  - Refactored this chunk of code. Don't really know whether it
     15        ;   --> worked in the first place. Waiting for bug report to know.
    1016        ;  - Refactored all of APPDEL.
    1117        ;
     
    1319        ;  - Added ability to remove checked in appointments. Added a couple
    1420        ;    of units tests for that under UT2.
    15         ;
    16         ; 3120625 VEN/SMH v1.7
    17         ;  - Transactions removed. Code refactored to work w/o txns.
    18         ;  - Moved AVUPDT to AVUPDTCN in BSDXAPI1. BSDXAPI takes care of calling
    19         ;    that.
     21        ;  - Minor reformatting because of how KIDS adds tabs.
    2022        ;
    2123        ; Error Reference:
     
    2931        ;  -8^BSDX08: Unable to find associated PIMS appointment for this patient
    3032        ;  -9^BSDX08: BSDXAPI returned an error: (error)
    31         ;  -10^BSDX08: $$BSDXCAN failed (Fileman filing error)
    3233        ;  -100~BSDX08 Error: (Mumps Error)
    3334        ;
    3435APPDELD(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
    3536        ;Entry point for debugging
    36         ;D DEBUG^%Serenji("APPDEL^BSDX08(.BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)")
    37         Q
    38         ;
    39 APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)         ; Private EP
     37        D DEBUG^%Serenji("APPDEL^BSDX08(.BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)")
     38        Q
     39        ;
     40UT      ; Unit Tests
     41        ; Test 1: Make normal appointment and cancel it. See if every thing works
     42        N ZZZ
     43        D APPADD^BSDX07(.ZZZ,3110123.2,3110123.3,4,"Dr Office",10,"Sam's Note",1)
     44        S APPID=+$P(^BSDXTMP($J,1),U)
     45        D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Sam's Cancel Note")
     46        I $P(^BSDXAPPT(APPID,0),U,12)'>0 W "Error in Cancellation-1"
     47        I $O(^SC(2,"S",3110123.2,1,0))]"" W "Error in Cancellation-2"
     48        I $P(^DPT(4,"S",3110123.2,0),U,2)'="PC" W "Error in Cancellation-3"
     49        I ^DPT(4,"S",3110123.2,"R")'="Sam's Cancel Note" W "Error in Cancellation-4"
     50        ;
     51        ; Test 2: Check for -1
     52        ; Make appt
     53        D APPADD^BSDX07(.ZZZ,3110125.2,3110125.3,4,"Dr Office",10,"Sam's Note",1)
     54        ; Lock the node in another job
     55        S APPID=+$P(^BSDXTMP($J,1),U)
     56        ; W "Lock ^BSDXAPPT("_APPID_") in another session. You have 10 seconds." H 10
     57        D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Sam's Cancel Note")
     58        ;
     59        ; Test 3: Check for -100
     60        S bsdxdie=1
     61        D APPADD^BSDX07(.ZZZ,3110126.2,3110126.3,4,"Dr Office",10,"Sam's Note",1)
     62        S APPID=+$P(^BSDXTMP($J,1),U)
     63        D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Reasons")
     64        I $P(^BSDXTMP($J,1),"~")'=-100 W "Error in -100",!
     65        K bsdxdie
     66        ;
     67        ; Test 4: Restartable transaction
     68        S bsdxrestart=1
     69        D APPADD^BSDX07(.ZZZ,3110128.2,3110128.3,4,"Dr Office",10,"Sam's Note",1)
     70        S APPID=+$P(^BSDXTMP($J,1),U)
     71        D APPDEL^BSDX08(.ZZZ,APPID,"PC",1,"Reasons")
     72        I $P(^DPT(4,"S",3110128.2,0),U,2)'="PC" W "Error in Restartable Transaction",!
     73        ;
     74        ; Test 5: for invalid Appointment ID (-2 and -3)
     75        D APPDEL^BSDX08(.ZZZ,0,"PC",1,"Reasons")
     76        I $P(^BSDXTMP($J,1),"~")'=-2 W "Error in -2",!
     77        D APPDEL^BSDX08(.ZZZ,999999,"PC",1,"Reasons")
     78        I $P(^BSDXTMP($J,1),"~")'=-3 W "Error in -3",!
     79UT2     ; More unit Tests
     80        ;
     81        ; Test 6: for Cancelling walkin and checked-in appointments
     82        S BSDXSTART=$E($$NOW^XLFDT,1,12),BSDXEND=BSDXSTART+.0001
     83        D APPADD^BSDX07(.ZZZ,BSDXSTART,BSDXEND,4,"Dr Office",10,"Sam's Note",1) ; Add appt
     84        S APPID=+$P(^BSDXTMP($J,1),U)
     85        I APPID=0 W "Error in test 6",!
     86        D CHECKIN^BSDX25(.ZZZ,APPID,$$NOW^XLFDT) ; check-in
     87        D APPDEL^BSDX08(.ZZZ,APPID,"PC",10,"Cancel Note") ; Delete appt
     88        I $P(^BSDXTMP($J,1),$C(30))'="" W "Error in test 6",!
     89        ;
     90        ; Test 7: for cancelling walkin and checked-in appointments
     91        S BSDXSTART=$E($$NOW^XLFDT,1,12)+.0001,BSDXEND=BSDXSTART+.0001
     92        D APPADD^BSDX07(.ZZZ,BSDXSTART,BSDXEND,4,"Dr Office",10,"Sam's Note",1) ; Add appt
     93        S APPID=+$P(^BSDXTMP($J,1),U)
     94        I APPID=0 W "Error in test 6",!
     95        D CHECKIN^BSDX25(.ZZZ,APPID,$$NOW^XLFDT) ; Checkin
     96        S BSDXRES=$O(^BSDXRES("B","Dr Office",""))
     97        S BSDXCLN=$P(^BSDXRES(BSDXRES,0),U,4)
     98        S BSDXRESULT=$$RMCI^BSDXAPI(4,BSDXCLN,BSDXSTART) ; remove checkin
     99        D APPDEL^BSDX08(.ZZZ,APPID,"PC",10,"Cancel Note") ; delete appt
     100        I $P(^BSDXTMP($J,1),$C(30))'="" W "Error in test 6",!
     101        QUIT
     102APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)         ;EP
    40103        ;Called by RPC: BSDX CANCEL APPOINTMENT
    41104        ;Cancels existing appointment in BSDX APPOINTMENT and 44/2 subfiles
     
    61124        ; Counter
    62125        N BSDXI S BSDXI=0
    63         ;
    64126        ; Header Node
    65127        S ^BSDXTMP($J,BSDXI)="T00100ERRORID"_$C(30)
     128        ;
     129        ; Lock BSDX node, only to synchronize access to the globals.
     130        ; It's not expected that the error will ever happen as no filing
     131        ; is supposed to take 5 seconds.
     132        L +^BSDXAPPT(BSDXAPTID):5 I '$T D ERR(BSDXI,"-1~BSDX08: Appt record is locked. Please contact technical support.") Q
     133        ;
     134        ;Restartable Transaction; restore paramters when starting.
     135        ; (Params restored are what's passed here + BSDXI)
     136        TSTART (BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT,BSDXI):T="BSDX CANCEL APPOINTEMENT^BSDX08"
    66137        ;
    67138        ; Turn off SDAM APPT PROTOCOL BSDX Entries
     
    70141        ;
    71142        ;;;test for error inside transaction. See if %ZTER works
    72         I $G(BSDXDIE1) N X S X=1/0
     143        I $G(bsdxdie) S X=1/0
     144        ;;;test
     145        ;;;test for TRESTART
     146        I $G(bsdxrestart) K bsdxrestart TRESTART
     147        ;;;test
    73148        ;
    74149        ; Check appointment ID and whether it exists
    75150        I '+BSDXAPTID D ERR(BSDXI,"-2~BSDX08: Invalid Appointment ID") Q
    76151        I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"-3~BSDX08: Invalid Appointment ID") Q
    77         ;
    78         ; Lock BSDX node, only to synchronize access to the globals.
    79         ; It's not expected that the error will ever happen as no filing
    80         ; is supposed to take 5 seconds.
    81         L +^BSDXAPPT(BSDXAPTID):5 E  D ERR(BSDXI,"-1~BSDX08: Appt record is locked. Please contact technical support.") Q
    82152        ;
    83153        ; Start Processing:
    84         ; First, get data
     154        ; First, add cancellation date to appt entry in BSDX APPOINTMENT
    85155        N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPTID,0) ; BSDX Appt Node
    86156        N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; Patient ID
    87157        N BSDXSTART S BSDXSTART=$P(BSDXNOD,U) ; Start Time
    88         ;
    89         ; Check the resource ID and whether it exists
     158        D BSDXCAN(BSDXAPTID)  ; Add a cancellation date in BSDX APPOINTMENT
     159        ;
     160        ; Second, cancel appt in "S" nodes in file 2 and 44, then update Legacy PIMS Availability
    90161        N BSDXSC1 S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID
    91         ; If the resource id doesn't exist...
     162        ; If the resouce id doesn't exist...
    92163        I BSDXSC1="" D ERR(BSDXI,"-4~BSDX08: Cancelled appointment does not have a Resouce ID") QUIT
    93164        I '$D(^BSDXRES(BSDXSC1,0)) D ERR(BSDXI,"-5~BSDX08: Resouce ID does not exist in BSDX RESOURCE") QUIT
    94         ;
    95         ;
    96         ; Check if PIMS will let us cancel the appointment using $$CANCELCK^BSDXAPI
    97165        ; Get zero node of resouce
    98         N BSDXNOD S BSDXNOD=^BSDXRES(BSDXSC1,0)
     166        S BSDXNOD=^BSDXRES(BSDXSC1,0)
    99167        ; Get Hosp location
    100168        N BSDXLOC S BSDXLOC=$P(BSDXNOD,U,4)
    101         ; Error indicator
     169        ; Error indicator for Hosp Location filing for getting out of routine
    102170        N BSDXERR S BSDXERR=0
    103         ;
    104         N BSDXC ; Array to pass to BSDXAPI
    105         ;
    106         I BSDXLOC D
    107         . S BSDXC("PAT")=BSDXPATID
    108         . S BSDXC("CLN")=BSDXLOC
    109         . S BSDXC("TYP")=BSDXTYP
    110         . S BSDXC("ADT")=BSDXSTART
    111         . S BSDXC("CDT")=$$NOW^XLFDT()
    112         . S BSDXC("NOT")=BSDXNOT
    113         . S:'+$G(BSDXCR) BSDXCR=11 ;Other
    114         . S BSDXC("CR")=BSDXCR
    115         . S BSDXC("USR")=DUZ
    116         . ;
    117         . S BSDXERR=$$CANCELCK^BSDXAPI(.BSDXC) ; 0 or 1^error message
    118         ; If error, quit. No need to rollback as no changes took place.
    119         I BSDXERR D ERR(BSDXI,"-9~BSDX08: BSDXAPI reports that "_$P(BSDXERR,U,2)) QUIT
    120         ;
    121         I $G(BSDXDIE2) N X S X=1/0
    122         ;
    123         ; Now cancel the appointment for real
    124         ; BSDXAPPT First; no need for rollback if error occured.
    125         N BSDXERR S BSDXERR=$$BSDXCAN(BSDXAPTID)  ; Add a cancellation date in BSDX APPOINTMENT
    126         I BSDXERR D ERR(BSDXI,"-10~BSDX08: $$BSDXCAN failed (Fileman filing error): "_$P(BSDXERR,U,2)) QUIT
    127         ;
    128         ; Then PIMS:
    129         ; cancel appt in "S" nodes in file 2 and 44, then update Legacy PIMS Availability
    130         ; If error happens, must rollback ^BSDXAPPT
    131         I BSDXLOC S BSDXERR=$$CANCEL^BSDXAPI(.BSDXC) ; Cancel through BSDXAPI
    132         ; Rollback BSDXAPPT if error occurs
    133         I BSDXERR D ERR(BSDXI,"-9^BSDX08: BSDXAPI returned an error: "_$P(BSDXERR,U,2)),ROLLBACK(BSDXAPTID)  QUIT
    134         ;
     171        ; Only file in 2/44 if there is an associated hospital location
     172        I BSDXLOC D  QUIT:BSDXERR 
     173        . I '$D(^SC(BSDXLOC,0)) S BSDXERR=1 D ERR(BSDXI,"-6~BSDX08: Invalid Hosp Location stored in Database") QUIT
     174        . ; Get the IEN of the appointment in the "S" node of ^SC
     175        . N BSDXSCIEN
     176        . S BSDXSCIEN=$$SCIEN^BSDXAPI(BSDXPATID,BSDXLOC,BSDXSTART)
     177        . I BSDXSCIEN="" S BSDXERR=1 D ERR(BSDXI,"-7~BSDX08: Patient does not have an appointment in PIMS Clinic") QUIT
     178        . ; Get the appointment node
     179        . S BSDXNOD=$G(^SC(BSDXLOC,"S",BSDXSTART,1,BSDXSCIEN,0))
     180        . I BSDXNOD="" S BSDXERR=1 D ERR(BSDXI,"-8^BSDX08: Unable to find associated PIMS appointment for this patient") QUIT
     181        . N BSDXLEN S BSDXLEN=$P(BSDXNOD,U,2)
     182        . ; Cancel through BSDXAPI
     183        . N BSDXZ
     184        . D APCAN(.BSDXZ,BSDXLOC,BSDXPATID,BSDXSTART)
     185        . I +BSDXZ>0 S BSDXERR=1 D ERR(BSDXI,"-9^BSDX08: BSDXAPI returned an error: "_$P(BSDXZ,U,2)) QUIT
     186        . ; Update Legacy PIMS clinic Availability
     187        . D AVUPDT(BSDXLOC,BSDXSTART,BSDXLEN)
     188        ;
     189        TCOMMIT
    135190        L -^BSDXAPPT(BSDXAPTID)
    136191        S BSDXI=BSDXI+1
     
    140195        Q
    141196        ;
    142 BSDXCAN(BSDXAPTID)      ; $$; Private; Cancel BSDX APPOINTMENT entry
    143         ; Input: Appt IEN in ^BSDXAPPT
    144         ; Output: 0 for success and 1^Msg for failure
    145         N BSDXDATE,BSDXIENS,BSDXFDA,BSDXMSG
    146         S BSDXDATE=$$NOW^XLFDT()
     197AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)       ;Update Legacy PIMS Clinic availability
     198        ;See SDCNP0
     199        N SD,S  ; Start Date
     200        S (SD,S)=BSDXSTART
     201        N I ; Clinic IEN in 44
     202        S I=BSDXSCD
     203        ; if day has no schedule in legacy PIMS, forget about this update.
     204        Q:'$D(^SC(I,"ST",SD\1,1))
     205        N SL ; Clinic characteristics node (length of appt, when appts start etc)
     206        S SL=^SC(I,"SL")
     207        N X ; Hour Clinic Display Begins
     208        S X=$P(SL,U,3)
     209        N STARTDAY ; When does the day start?
     210        S STARTDAY=$S($L(X):X,1:8) ; If defined, use it; otherwise, 8am
     211        N SB ; ?? Who knows? Day Start - 1 divided by 100.
     212        S SB=STARTDAY-1/100
     213        S X=$P(SL,U,6) ; Now X is Display increments per hour
     214        N HSI ; Slots per hour, try 1
     215        S HSI=$S(X:X,1:4) ; if defined, use it; otherwise, 4
     216        N SI ; Slots per hour, try 2
     217        S SI=$S(X="":4,X<3:4,X:X,1:4) ; If slots "", or less than 3, then 4
     218        N STR ; ??
     219        S STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
     220        N SDDIF ; Slots per hour diff??
     221        S SDDIF=$S(HSI<3:8/HSI,1:2)
     222        S SL=BSDXLEN ; Dammit, reusing variable; SL now Appt Length from GUI
     223        S S=^SC(I,"ST",SD\1,1) ; reusing var again; S now Day Pattern from PIMS
     224        N Y ; Hours since start of Date
     225        S Y=SD#1-SB*100 ;SD#1=FM Time portion; -SB minus start of day; conv to hrs
     226        N ST  ; ??
     227        ; Y#1 -> Minutes; *SI -> * Slots per hour; \.6 trunc min to hour
     228        ; Y\1 -> Hours since start of day; * SI: * slots
     229        S ST=Y#1*SI\.6+(Y\1*SI)
     230        N SS ; how many slots are supposed to be taken by appointment
     231        S SS=SL*HSI/60 ; (nb: try SL: 30 min; HSI: 4 slots)
     232        N I
     233        I Y'<1 D  ; If Hours since start of Date is greater than 1
     234        . ; loop through pattern. Tired of documenting.
     235        . F I=ST+ST:SDDIF D  Q:Y=""  Q:SS'>0
     236        . . S Y=$E(STR,$F(STR,$E(S,I+1))) Q:Y="" 
     237        . . S S=$E(S,1,I)_Y_$E(S,I+2,999)
     238        . . S SS=SS-1
     239        . . Q:SS'>0
     240        S ^SC(BSDXSCD,"ST",SD\1,1)=S  ; new pattern; global set
     241        Q
     242        ;
     243APCAN(BSDXZ,BSDXLOC,BSDXDFN,BSDXSD)             ;
     244        ;Cancel appointment for patient BSDXDFN in clinic BSDXSC1
     245        ;at time BSDXSD
     246        N BSDXC,%H
     247        S BSDXC("PAT")=BSDXPATID
     248        S BSDXC("CLN")=BSDXLOC
     249        S BSDXC("TYP")=BSDXTYP
     250        S BSDXC("ADT")=BSDXSD
     251        S %H=$H D YMD^%DTC
     252        S BSDXC("CDT")=X+%
     253        S BSDXC("NOT")=BSDXNOT
     254        S:'+$G(BSDXCR) BSDXCR=11 ;Other
     255        S BSDXC("CR")=BSDXCR
     256        S BSDXC("USR")=DUZ
     257        ;
     258        S BSDXZ=$$CANCEL^BSDXAPI(.BSDXC)
     259        Q
     260        ;
     261BSDXCAN(BSDXAPTID)      ;
     262        ;Cancel BSDX APPOINTMENT entry
     263        N %DT,X,BSDXDATE,Y,BSDXIENS,BSDXFDA,BSDXMSG
     264        S %DT="XT",X="NOW" D ^%DT ; X ^DD("DD")
     265        S BSDXDATE=Y
    147266        S BSDXIENS=BSDXAPTID_","
    148267        S BSDXFDA(9002018.4,BSDXIENS,.12)=BSDXDATE
     268        K BSDXMSG
    149269        D FILE^DIE("","BSDXFDA","BSDXMSG")
    150         I $D(BSDXMSG) Q 1_U_BSDXMSG("DIERR",1,"TEXT",1)
    151         QUIT 0
    152         ;
    153 ROLLBACK(BSDXAPTID)      ; Proc; Private; Rollback cancellation
    154         ; Input same as $$BSDXCAN
    155         N BSDXIENS S BSDXIENS=BSDXAPTID_","
    156         N BSDXFDA S BSDXFDA(9002018.4,BSDXIENS,.12)="@"
    157         N BSDXMSG
    158         D FILE^DIE("","BSDXFDA","BSDXMSG")
    159         ;I $D(BSDXMSG)  ; Not sure what to do. We are already handling an error.
    160         QUIT
     270        Q
    161271        ;
    162272CANEVT(BSDXPAT,BSDXSTART,BSDXSC)        ;EP Called by BSDX CANCEL APPOINTMENT event
     
    182292        Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND
    183293        S BSDXAPPT=0 F  S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT  D  Q:BSDXFOUND
    184         . N BSDXNOD
    185294        . S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
    186295        . I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q
    187         I BSDXFOUND,+$G(BSDXAPPT) N % S %=$$BSDXCAN(BSDXAPPT) I % D ^%ZTER
     296        I BSDXFOUND,+$G(BSDXAPPT) D BSDXCAN(BSDXAPPT)
    188297        Q BSDXFOUND
    189298        ;
     
    200309        ;
    201310ERR(BSDXI,BSDXERR)      ;Error processing
    202         ; Unlock first
    203         L:$D(BSDXAPTID) -^BSDXAPPT(BSDXAPTID)
    204         ; If last line is $C(31), we are done. No more errors to send to client.
    205         I ^BSDXTMP($J,$O(^BSDXTMP($J," "),-1))=$C(31) QUIT
    206311        S BSDXI=BSDXI+1
    207312        S BSDXERR=$TR(BSDXERR,"^","~")
     313        I $TL>0 TROLLBACK
    208314        S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
    209315        S BSDXI=BSDXI+1
    210316        S ^BSDXTMP($J,BSDXI)=$C(31)
     317        L -^BSDXAPPT(BSDXAPTID)
    211318        QUIT
    212319        ;
    213320ETRAP   ;EP Error trap entry
    214321        N $ET S $ET="D ^%ZTER HALT"  ; Emergency Error Trap
     322        ; Rollback, otherwise ^XTER will be empty from future rollback
     323        I $TL>0 TROLLBACK
    215324        D ^%ZTER
    216         ;
    217         ; Roll back BSDXAPPT;
    218         ; NB: What if a Mumps error happens inside fileman in BSDXAPI?
    219         ; I have decided the M errors are out of scope for me to handle.
    220         D:$G(BSDXAPTID) ROLLBACK(BSDXAPTID)
    221         ;
     325        S $EC=""  ; Clear Error
    222326        ; Log error message and send to client
    223327        I '$D(BSDXI) N BSDXI S BSDXI=0
    224328        D ERR(BSDXI,"-100~BSDX08 Error: "_$G(%ZTERZE))
    225         Q:$Q 1_U_"-100~Mumps Error" Q
     329        QUIT
    226330        ;
    227331        ;;;NB: This is code that is unused in both original and port.
  • Scheduling/trunk/m/BSDX09.m

    r1481 r1563  
    1 BSDX09  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;  ; 6/21/12 11:03am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     1BSDX09  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;  ; 4/28/11 10:18am
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX11.m

    r1481 r1563  
    11BSDX11  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:18am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX12.m

    r1481 r1563  
    11BSDX12  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:18am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX13.m

    r1481 r1563  
    11BSDX13  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:19am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX14.m

    r1481 r1563  
    11BSDX14  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:19am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX15.m

    r1481 r1563  
    11BSDX15  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:19am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX16.m

    r1481 r1563  
    11BSDX16  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;  ; 4/28/11 10:20am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX17.m

    r1481 r1563  
    11BSDX17  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:20am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX18.m

    r1481 r1563  
    11BSDX18  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:20am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX19.m

    r1481 r1563  
    11BSDX19  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:21am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX20.m

    r1481 r1563  
    11BSDX20  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:21am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX21.m

    r1481 r1563  
    11BSDX21  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:22am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX22.m

    r1481 r1563  
    11BSDX22  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:22am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX23.m

    r1481 r1563  
    11BSDX23  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:22am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX24.m

    r1481 r1563  
    11BSDX24  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:22am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX25.m

    r1481 r1563  
    1 BSDX25  ; VEN/SMH - WINDOWS SCHEDULING RPCS ; 7/9/12 5:00pm
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     1BSDX25  ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 4/28/11 10:24am
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
    55        ; Change Log:
    66        ; 3110106: SMH -> Changed Check-in EP - Removed unused paramters. Will change C#
    7         ; 3120630: VEN/SMH -> Extensive Refactoring to remove transactions.
    8         ;                  -> Functionality still the same.
    9         ;                  -> Unit Tests in UT25^BSDXUT2
    10         ;
    11         ;
    12 CHECKIND(BSDXY,BSDXAPPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG)        ;EP
     7        ;
     8        ;
     9UT      ; Unit Tests
     10        ; Make appointment, checkin, then uncheckin
     11        N ZZZ
     12        N APPTTIME S APPTTIME=$E($$NOW^XLFDT(),1,12)
     13        D APPADD^BSDX07(.ZZZ,APPTTIME,APPTTIME+.0001,3,"Dr Office",30,"Sam's Note",1)
     14        N APPTID S APPTID=+^BSDXTMP($J,1)
     15        N HL S HL=$$GET1^DIQ(9002018.4,APPTID,".07:.04","I")
     16        D CHECKIN^BSDX25(.ZZZ,APPTID,$$NOW^XLFDT())
     17        IF '$P(^BSDXAPPT(APPTID,0),U,3) WRITE "ERROR IN CHECKIN 1",!
     18        IF '+$G(^SC(HL,"S",APPTTIME,1,1,"C")) WRITE "ERROR IN CHECKIN 2",!
     19        D RMCI^BSDX25(.ZZZ,APPTID)
     20        IF $P(^BSDXAPPT(APPTID,0),U,3) WRITE "ERROR IN UNCHECKIN 1",!
     21        IF $G(^SC(HL,"S",APPTTIME,1,1,"C")) WRITE "ERROR IN UNCHECKIN 2",!
     22        D RMCI^BSDX25(.ZZZ,APPTID)  ; again, test sanity in repeat
     23        IF $P(^BSDXAPPT(APPTID,0),U,3) WRITE "ERROR IN UNCHECKIN 1",!
     24        IF $G(^SC(HL,"S",APPTTIME,1,1,"C")) WRITE "ERROR IN UNCHECKIN 2",!
     25        ; now test various error conditions
     26        ; Test Error 1
     27        D RMCI^BSDX25(.ZZZ,)
     28        IF +^BSDXTMP($J,1)'=-1 WRITE "ERROR IN ETest 1",!
     29        ; Test Error 2
     30        D RMCI^BSDX25(.ZZZ,234987234398)
     31        IF +^BSDXTMP($J,1)'=-2 WRITE "ERROR IN Etest 2",!
     32        ; Tests for 3 to 5 difficult to produce
     33        ; Error tests follow: Mumps error test; Transaction restartability
     34        N bsdxdie S bsdxdie=1
     35        D RMCI^BSDX25(.ZZZ,APPTID)
     36        IF +^BSDXTMP($J,1)'=-20 WRITE "ERROR IN Etest 3",!
     37        K bsdxdie
     38        N bsdxrestart S bsdxrestart=1
     39        D RMCI^BSDX25(.ZZZ,APPTID)
     40        IF +^BSDXTMP($J,1)'=0 WRITE "Error in Etest 4",!
     41        QUIT
     42CHECKIND(BSDXY,BSDXAPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG) ;EP
    1343        ;Entry point for debugging
    1444        ;
    15         ;I +$G(^BSDXDBUG("BREAK","CHECKIN")),+$G(^BSDXDBUG("BREAK"))=DUZ D DEBUG^%Serenji("CHECKIN^BSDX25(.BSDXY,BSDXAPPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG)",$P(^BSDXDBUG("BREAK"),U,2))
    16         Q
    17         ;
    18 CHECKIN(BSDXY,BSDXAPPTID,BSDXCDT)       ;Private EP Check in appointment
    19         ; Old additional vars: ,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG)
    20         ; Called by RPC: BSDX CHECKIN APPOINTMENT
    21         ;
     45        ;I +$G(^BSDXDBUG("BREAK","CHECKIN")),+$G(^BSDXDBUG("BREAK"))=DUZ D DEBUG^%Serenji("CHECKIN^BSDX25(.BSDXY,BSDXAPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG)",$P(^BSDXDBUG("BREAK"),U,2))
     46        Q
     47        ;
     48CHECKIN(BSDXY,BSDXAPTID,BSDXCDT)        ; ,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG)       ;EP Check in appointment
    2249        ; Private to GUI; use BSDXAPI for general API to checkin patients
    2350        ; Parameters:
    2451        ; BSDXY: Global Out
    25         ; BSDXAPPTID: Appointment ID in ^BSDXAPPT
     52        ; BSDXAPTID: Appointment ID in ^BSDXAPPT
    2653        ; BSDXCDT: Checkin Date --> Changed
    2754        ; BSDXCC: Clinic Stop IEN (not used)
     
    3057        ; BSDXVCL: PCC+ Clinic IEN (not used)
    3158        ; BSDXVFM: PCC+ Form IEN (not used)
    32         ; BSDXOG: PCC+ Outguide (true or false) (not used)
     59        ; BSDXOG: PCC+ Outguide (true or false)
    3360        ;
    3461        ; Output:
     
    3663        ; - 0 if all okay
    3764        ; - Another number or text if not
    38         ;
    39         ; Error reference:
    40         ; -1 -> Invalid Appointment ID
    41         ; -2 -> Invalid Check-in Date
    42         ; -3 -> Cannot check-in due to Fileman Filer failure
    43         ; -4 -> Cannot lock ^BSDXAPPT(APPTID)
    44         ; -10 -> BSDXAPI error
    45         ; -100 -> Mumps Error
    46         ;
    47         ; Turn off SDAM Appointment Events BSDX Protocol Processing
     65       
     66        N BSDXNOD,BSDXPATID,BSDXSTART,DIK,DA,BSDXID,BSDXI,BSDXZ,BSDXIENS,BSDXVEN
    4867        N BSDXNOEV
    4968        S BSDXNOEV=1 ;Don't execute protocol
    5069        ;
    51         ; Set min DUZ vars
    52         D ^XBKVAR
    53         ;
    54         ; $ET
    55         N $ET S $ET="G ERROR^BSDX25"
    56         ;
    57         ; Test for error trap for Unit Tests
    58         I $G(BSDXDIE) N X S X=1/0
    59         ;
    60         N BSDXI S BSDXI=0
    61         ;
    62         S BSDXY=$NAME(^BSDXTMP($J))
    63         K @BSDXY
    64         ;
     70        D ^XBKVAR S X="ERROR^BSDX25",@^%ZOSF("TRAP")
     71        S BSDXI=0
     72        K ^BSDXTMP($J)
     73        S BSDXY="^BSDXTMP("_$J_")"
    6574        S ^BSDXTMP($J,0)="T00020ERRORID"_$C(30)
    66         ;
    67         I '+BSDXAPPTID D ERR("-1~Invalid Appointment ID") QUIT
    68         I '$D(^BSDXAPPT(BSDXAPPTID,0)) D ERR("-1~Invalid Appointment ID") QUIT
    69         ;
    70         ; Lock BSDX node, only to synchronize access to the globals.
    71         ; It's not expected that the error will ever happen as no filing
    72         ; is supposed to take 5 seconds.
    73         L +^BSDXAPPT(BSDXAPPTID):5 E  D ERR("-4~Appt record is locked. Please contact technical support.") QUIT
    74         ;
     75        I '+BSDXAPTID D ERR("BSDX25: Invalid Appointment ID") Q
     76        I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR("BSDX08: Invalid Appointment ID") Q
    7577        ; Remove Date formatting v.1.5. Client will send date as FM Date.
    7678        ;S:BSDXCDT["@0000" BSDXCDT=$P(BSDXCDT,"@")
    7779        ;S %DT="T",X=BSDXCDT D ^%DT S BSDXCDT=Y
    78         S BSDXCDT=+BSDXCDT  ; Strip off zeros if C# sends them
    79         I BSDXCDT'>2000000 D ERR("-2~Invalid Check-in Date") QUIT
     80           S BSDXCDT=+BSDXCDT  ; Strip off zeros if C# sends them
     81        I BSDXCDT=-1 D ERR(70) Q
    8082        I BSDXCDT>$$NOW^XLFDT S BSDXCDT=$$NOW^XLFDT
    81         ;
    82         ; Some data
    83         N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPPTID,0) ; Appointment Node
    84         N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; DFN
    85         N BSDXSTART S BSDXSTART=$P(BSDXNOD,U) ; Appointment Start Time
    86         ;
    87         ; Get Hospital Location IEN from BSDXAPPT to BSDXRES (RESOUCE:HOSPITAL LOCATION)
    88         N BSDXSC1 S BSDXSC1=$$GET1^DIQ(9002018.4,BSDXAPPTID_",",".07:.04","I")
    89         I BSDXSC1,'$D(^SC(BSDXSC1,0)) S BSDXSC1="" ; Null it off if it doesn't exist
    90         ;
    91         ; Check if we can check-in using BSDXAPI
    92         N BSDXERR S BSDXERR=0
    93         I BSDXSC1 S BSDXERR=$$CHECKIC1^BSDXAPI(BSDXPATID,BSDXSC1,BSDXSTART)
    94         I BSDXERR D ERR(-10_"~"_$P(BSDXERR,U,2)) QUIT
    95         ;
    96         ; Checkin BSDX APPOINTMENT entry
    97         ; Failure Analysis: If we fail here, no changes were made.
    98         N BSDXERR S BSDXERR=$$BSDXCHK(BSDXAPPTID,BSDXCDT)
    99         I BSDXERR D ERR("-3~Fileman Filer failed to check-in appt") QUIT
    100         ;
    101         ; File check-in using BSDXAPI
    102         ; Failure Analysis: If we fail here, we need to roll back first check-in.
    103         N BSDXERR S BSDXERR=0
    104         I BSDXSC1 S BSDXERR=$$CHECKIN1^BSDXAPI(BSDXPATID,BSDXSC1,BSDXSTART)
    105         I BSDXERR D  QUIT
    106         . N % S %=$$BSDXCHK(BSDXAPPTID,"@") ; No Error checking to prevent loop.
    107         . D ERR(-10_"~"_$P(BSDXERR,U,2)) ; Send error message to client
    108         ;
    109         L -^BSDXAPPT(BSDXAPPTID)
     83        ;Checkin BSDX APPOINTMENT entry
     84        D BSDXCHK(BSDXAPTID,BSDXCDT)
     85        S BSDXNOD=^BSDXAPPT(BSDXAPTID,0)
     86        S BSDXPATID=$P(BSDXNOD,U,5)
     87        S BSDXSTART=$P(BSDXNOD,U)
     88        ;
     89        S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID
     90        I BSDXSC1]"",$D(^BSDXRES(BSDXSC1,0)) D  I +$G(BSDXZ) D ERR($P(BSDXZ,U,2)) Q
     91        . S BSDXNOD=^BSDXRES(BSDXSC1,0)
     92        . S BSDXSC1=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION
     93        . I BSDXSC1]"",$D(^SC(BSDXSC1,0)) D APCHK(.BSDXZ,BSDXSC1,BSDXPATID,BSDXCDT,BSDXSTART)
     94        ;
    11095        S BSDXI=BSDXI+1
    11196        S ^BSDXTMP($J,BSDXI)="0"_$C(30)
     
    11499        Q
    115100        ;
    116 BSDXCHK(BSDXAPPTID,BSDXCDT)     ; $$ Private Entry Point. File or delete check-in to
    117         ; BSDX Appointment
    118         ; Input: BSDXAPPTID -> Appointment ID
    119         ;        BSDXCDT -> Check-in date, or "@" to remove check-in.
    120         ;
    121         ; Output: 1^Error for error
    122         ;         0 for success
    123         ;
    124         Q:$G(BSDXSIMERR1) 1_U_"Simulated Error 1"
    125         ;
    126         N BSDXIENS,BSDXMSG,BSDXFDA ; Filer variables
    127         S BSDXIENS=BSDXAPPTID_","
     101BSDXCHK(BSDXAPTID,BSDXCDT)      ;
     102        ;
     103        S BSDXIENS=BSDXAPTID_","
    128104        S BSDXFDA(9002018.4,BSDXIENS,.03)=BSDXCDT
    129105        D FILE^DIE("","BSDXFDA","BSDXMSG")
    130         Q:$D(BSDXMSG) 1_U_BSDXMSG("DIERR",1,"TEXT",1)
    131         Q 0
    132         ;
    133 RMCI(BSDXY,BSDXAPPTID)  ; Private EP - Remove Check-in from BSDX APPT and 2/44
    134         ; Called by RPC BSDX REMOVE CHECK-IN
     106        Q
     107        ;
     108APCHK(BSDXZ,BSDXSC1,BSDXDFN,BSDXCDT,BSDXSTART)          ;
     109        ;Checkin appointment for patient BSDXDFN in clinic BSDXSC1
     110        ;at time BSDXSTART
     111        S BSDXZ=$$CHECKIN1^BSDXAPI(BSDXDFN,BSDXSC1,BSDXSTART)
     112        Q
     113        ;
     114RMCI(BSDXY,BSDXAPPTID)  ; EP - Remove Check-in from BSDX APPT and 2/44
     115        ; Called by RPC [Fill in later]
    135116        ;
    136117        ; Parameters to pass:
     
    147128        ; -4~DB has corruption. Call Tech Support. (Resource ID in BSDXAPPT doesnt exist in BSDXRES)
    148129        ; -5~BSDXAPI Error. Message depends on error.
    149         ; -6~Data Filing Error in BSDXCHK
    150         ; -7~Lock not acquired
    151         ; -100~Mumps Error
     130        ; -20~Mumps Error
    152131        ;
    153132        N BSDXNOEV S BSDXNOEV=1 ;Don't execute protocol
     
    163142        S ^BSDXTMP($J,BSDXI)="T00020ERRORID"_$C(30) ; Header of ADO recordset
    164143        ;
     144        TSTART (BSDXI):SERIAL ; Perform Autolocking
     145        ;
    165146        ;;;test
    166         I $G(BSDXDIE) N X S X=8/0
     147        I $g(bsdxdie) S X=8/0
     148        ;;;
     149        I $g(bsdxrestart) k bsdxrestart TRESTART
     150        ;;;test
    167151        ;
    168152        ; Check for Appointment ID (passed and exists in file)
     
    170154        I '$D(^BSDXAPPT(BSDXAPPTID,0)) D ERR("-2~Invalid Appointment ID") QUIT
    171155        ;
    172         ; Lock
    173         ; Timeout not expected to happen except in error conditions.
    174         L +^BSDXAPPT(BSDXAPPTID):5 E  D ERR("-7~Appt record is locked. Please contact technical support.") QUIT
    175         ;
    176         ; Get appointment Data
     156        ; Remove checkin from BSDX APPOINTMENT entry
     157        D BSDXCHK(BSDXAPPTID,"@")
     158        ;
     159        ; Now, remove checkin from PIMS files 2/44
    177160        N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPPTID,0)
    178         N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; DFN
    179         N BSDXSTART S BSDXSTART=$P(BSDXNOD,U) ; Start Date
    180         N BSDXRESID S BSDXRESID=$P(BSDXNOD,U,7) ; Resource ID
     161        N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; DFN
     162        N BSDXSTART S BSDXSTART=$P(BSDXNOD,U)   ; Start Date
     163        N BSDXSC1 S BSDXSC1=$P(BSDXNOD,U,7) ; Resource ID
    181164        ;
    182165        ; If the resource doesn't exist, error out. DB is corrupt.
    183         I 'BSDXRESID D ERR("-3~DB has corruption. Call Tech Support.") QUIT
    184         I '$D(^BSDXRES(BSDXRESID,0)) D ERR("-4~DB has corruption. Call Tech Support.") QUIT
    185         ;
    186         ; Get HL Data
    187         N BSDXNOD S BSDXNOD=^BSDXRES(BSDXRESID,0) ; Resource 0 node
    188         N BSDXSC1 S BSDXSC1=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION IEN
    189         I BSDXSC1,'$D(^SC(BSDXSC1,0)) S BSDXSC1="" ; Zero out if HL doesn't exist
    190         ;
    191         ; Is it okay to remove check-in from PIMS?
    192         N BSDXERR S BSDXERR=0 ; Scratch variable
    193         ; $$RMCICK = Remove Check-in Check
    194         I BSDXSC1 S BSDXERR=$$RMCICK^BSDXAPI1(BSDXPATID,BSDXSC1,BSDXSTART)
    195         I BSDXERR D ERR("-5~"_$P(BSDXERR,U,2)) QUIT
    196         ;
    197         ; For possible rollback, get old check-in date (internal value)
    198         N BSDXCDT S BSDXCDT=$$GET1^DIQ(9002018.4,BSDXAPPTID_",",.03,"I")
    199         ;
    200         ; Remove checkin from BSDX APPOINTMENT entry
    201         ; No need to rollback here on failure.
    202         N BSDXERR S BSDXERR=$$BSDXCHK(BSDXAPPTID,"@")
    203         I BSDXERR D ERR("-6~Cannot file data in $$BSDXCHK") QUIT
    204         ;
    205         ; Now, remove checkin from PIMS files 2/44
    206         ; Restore BSDXCDT into ^BSDXAPPT if we fail.
    207         N BSDXERR S BSDXERR=0 ; Scratch variable to hold error message
    208         I BSDXSC1 S BSDXERR=$$RMCI^BSDXAPI1(BSDXPATID,BSDXSC1,BSDXSTART)
    209         I BSDXERR D  QUIT
    210         . N % S %=$$BSDXCHK(BSDXAPPTID,BSDXCDT) ; No error checking here.
    211         . D ERR("-5~"_$P(BSDXERR,U,2)) ; Send error message to client
    212         ;
    213         ; Unlock
    214         L -^BSDXAPPT(BSDXAPPTID)
     166        I 'BSDXSC1 D ERR("-3~DB has corruption. Call Tech Support.") QUIT
     167        I '$D(^BSDXRES(BSDXSC1,0)) D ERR("-4~DB has corruption. Call Tech Support.") QUIT
     168        ;
     169        N BSDXNOD S BSDXNOD=^BSDXRES(BSDXSC1,0) ; Resource 0 node
     170        S BSDXSC1=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION
     171        ;
     172        N BSDXZ ; Scratch variable to hold error message
     173        I BSDXSC1]"",$D(^SC(BSDXSC1,0)) S BSDXZ=$$RMCI^BSDXAPI(BSDXPATID,BSDXSC1,BSDXSTART)
     174        I +$G(BSDXZ) D ERR("-5~"_$P(BSDXZ,U,2)) QUIT
     175        ;
     176        TCOMMIT  ; Save Data into Globals
    215177        ;
    216178        ; Return ADO recordset
     
    246208        Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND
    247209        S BSDXAPPT=0 F  S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT  D  Q:BSDXFOUND
    248         . N BSDXNOD S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
     210        . S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
    249211        . I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q
    250         I BSDXFOUND,+$G(BSDXAPPT) D
    251         . N BSDXERR S BSDXERR=$$BSDXCHK(BSDXAPPT,BSDXSTAT)
    252         . I BSDXERR D ^%ZTER ; VEN/SMH - This is silent. This is a last resort
     212        I BSDXFOUND,+$G(BSDXAPPT) D BSDXCHK(BSDXAPPT,BSDXSTAT)
    253213        Q BSDXFOUND
    254214        ;
     
    265225ERROR   ;
    266226        S $ETRAP="D ^%ZTER HALT"  ; Emergency Error Trap for the wise
    267         D ^%ZTER
    268         ; VEN/SMH: NB: I make a conscious decision not to roll back anything
    269         ; here in the error trap. Once the error is fixed, users can
    270         ; undo or redo the check-in.
    271         ; Individual portions of this routine may choose to do rolling back
    272         ; of their own (e.g. a failed call to BSDXAPI causes rollback to occur
    273         ; in CHECKIN and RMCI)
    274         ;
    275         ; Log error message and send to client
    276         D ERR("-100~Mumps Error")
    277         Q:$Q "-100^Mumps Error" Q
     227           ; Rollback, otherwise ^XTER will be empty from future rollback
     228           I $TL>0 TROLLBACK
     229           D ^%ZTER
     230           S $EC=""  ; Clear Error
     231           ; Log error message and send to client
     232        D ERR("-20~Mumps Error")
     233        Q
    278234        ;
    279235ERR(BSDXERR)    ;Error processing
    280         ; Unlock first
    281         L:$D(BSDXAPPTID) -^BSDXAPPT(BSDXAPPTID)
    282         ; If last line is $C(31), we are done. No more errors to send to client.
    283         I ^BSDXTMP($J,$O(^BSDXTMP($J," "),-1))=$C(31) QUIT
     236        I $TLEVEL>0 TROLLBACK
    284237        S BSDXERR=$G(BSDXERR)
    285238        S BSDXERR=$P(BSDXERR,"~")_"~"_$TEXT(+0)_":"_$P(BSDXERR,"~",2) ; Append Routine Name
  • Scheduling/trunk/m/BSDX26.m

    r1481 r1563  
    1 BSDX26   ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/10/12 10:27am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
    3         ; Licensed under LGPL
    4         ; Change History:
    5         ; 3101023 - UJO/SMH - Addition of restartable transaction; relocation of tx.
    6         ; 3101205 - UJO/SMH - Extensive refactoring.
    7         ; 3120625 - VEN/SMH - Removal of Transactions, reloation of UTs to BSDXUT1
    8         ;
    9         ; Error Reference:
    10         ; 1: Appt ID is not a number
    11         ; 2: Appt IEN is not in ^BSDXAPPT
    12         ; 3: FM Failure to file WP field in ^BSDXAPPT
    13         ; 4: BSDXAPI reports failure to change note field in ^SC
    14         ; 5: Failure to acquire lock on ^BSDXAPPT(APPTID)
    15         ; 100: Mumps Error
    16         ;
    17         ; NB: Normally I use negative numbers for errors; this routine returns
    18         ;     -1 as a successful result! So I needed to use +ve numbers.
    19         ;
     1BSDX26   ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:24am
     2           ;;1.6;BSDX;;Aug 31, 2011;Build 25
     3           ; Licensed under LGPL
     4           ; Change History:
     5           ; 3101023 - UJO/SMH - Addition of restartable transaction; relocation of tx.
     6           ; --> Thanks to Zach Gonzalez and Rick Marshall
     7           ; 3101205 - UJO/SMH - Extensive refactoring.
     8           ;
     9           ; Error Reference:
     10           ; -1: Appt ID is not a number
     11           ; -2: Appt IEN is not in ^BSDXAPPT
     12           ; -3: FM Failure to file WP field in ^BSDXAPPT
     13           ;
    2014EDITAPTD(BSDXY,BSDXAPTID,BSDXNOTE)       ;EP
    21         ;Entry point for debugging
    22         ;
    23         ;D DEBUG^%Serenji("EDITAPT^BSDX26(.BSDXY,BSDXAPTID,BSDXNOTE)")
    24         Q
     15           ;Entry point for debugging
     16           ;
     17           D DEBUG^%Serenji("EDITAPT^BSDX26(.BSDXY,BSDXAPTID,BSDXNOTE)")
     18           Q
     19UT      ; Unit Tests
     20           ; Test 1: Make sure this damn thing works
     21           N ZZZ
     22           N %H S %H=$H
     23           N NOTE S NOTE="New Note "_%H
     24           D EDITAPT(.ZZZ,188,NOTE)
     25           I ^BSDXAPPT(188,1,1,0)'=NOTE W "ERROR",! B
     26           ; Test 2: Test Errors -1 and -2
     27           N ZZZ
     28           N NOTE S NOTE="Nothing important"
     29           D EDITAPT(.ZZZ,"BLAHBLAH",NOTE)
     30           I +^BSDXTMP($J,1)'=-1 W "ERROR IN -1",! B
     31           D EDITAPT(.ZZZ,298734322,NOTE)
     32           I +^BSDXTMP($J,1)'=-2 W "ERROR IN -2",! B
     33           ; Test 4: M Error
     34           N bsdxdie S bsdxdie=1
     35           D EDITAPT(.ZZZ,188,NOTE)
     36           I +^BSDXTMP($J,1)'=-100 W "ERROR IN -100",! B
     37           k bsdxdie
     38           ; Test 5: Trestart
     39           N bsdxrestart S bsdxrestart=1
     40           N %H S %H=$H
     41           N NOTE S NOTE="New Note "_%H
     42           D EDITAPT(.ZZZ,188,NOTE)
     43           I ^BSDXAPPT(188,1,1,0)'=NOTE W "ERROR in TRESTART",! B
     44           ; Test 6: for Hosp Location Update
     45           N DATE S DATE=$$NOW^XLFDT()
     46           S DATE=$E(DATE,1,12) ; Just get minutes b/c of HL file input transform
     47           D APPADD^BSDX07(.ZZZ,DATE,DATE+.001,3,"Dr Office",30,"Old Note",1)
     48           N APPID S APPID=+$P(^BSDXTMP($J,1),U)
     49           D EDITAPT(.ZZZ,APPID,"New Note")
     50           I ^BSDXAPPT(APTID,1,1,0)'="New Note" W "Error in HL Section",! B
     51           I $P(^SC(2,"S",DATE,1,1,0),U,4)'="New Note" W "Error in HL Section",! B
     52           QUIT
     53           ;
    2554EDITAPT(BSDXY,BSDXAPTID,BSDXNOTE)         ;EP Edit appointment (only note text can be edited)
    26         ; Called by RPC: BSDX EDIT APPOINTMENT
    27         ;
    28         ; Edits Appointment Text in BSDX APPOINTMENT file & Hosp Location (44) file
    29         ;
    30         ; Parameters:
    31         ; - BSDXY: Global Return (RPC must be set to Global Array)
    32         ; - BSDXAPTID: Appointment IEN in BSDX APPOINTMENT
    33         ; - BSDXNOTE: New note
    34         ;
    35         ; Return:
    36         ; ADO.net Recordset having 1 field: ERRORID
    37         ; If Okay: -1; otherwise, positive integer with message
    38         ;
    39         ; Return Array; set Return and clear array
    40         S BSDXY=$NA(^BSDXTMP($J))
    41         K ^BSDXTMP($J)
    42         ; ET
    43         N $ET S $ET="G ETRAP^BSDX26"
    44         ; Set up basic DUZ variables
    45         D ^XBKVAR
    46         ; Counter
    47         N BSDXI S BSDXI=0
    48         ; Header Node
    49         S ^BSDXTMP($J,BSDXI)="T00100ERRORID"_$C(30)
    50         ;
    51         ;;;test for error. See if %ZTER works
    52         I $G(BSDXDIE) S X=1/0
    53         ;
    54         ; Validate Appointment ID
    55         I '+BSDXAPTID D ERR(BSDXI,"1~BSDX26: Invalid Appointment ID") QUIT
    56         I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"2~BSDX26: Invalid Appointment ID") QUIT
    57         ;
    58         ; Lock BSDX node, only to synchronize access to the globals.
    59         ; It's not expected that the error will ever happen as no filing
    60         ; is supposed to take 5 seconds.
    61         L +^BSDXAPPT(BSDXAPTID):5 E  D ERR(BSDXI,"5~BSDX08: Appt record is locked. Please contact technical support.") QUIT
    62         ;
    63         ; Put the WP in decendant fields from the root to file as a WP field
    64         S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE=""
    65         I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0)
    66         ;
    67         N BSDXMSG ; Message in case of error in filing.
    68         ;
    69         ; Save Before State in case we need it for rollback
    70         K ^TMP($J)
    71         M ^TMP($J,"BEFORE","BSDXAPPT")=^BSDXAPPT(BSDXAPTID)
    72         ;
    73         ; Update note in BSDX APPOINTMENT
    74         I $D(BSDXNOTE(.5)) D
    75         . D WP^DIE(9002018.4,BSDXAPTID_",",1,"","BSDXNOTE","BSDXMSG")
    76         ;
    77         ; Error handling. No need for rollback since nothing else changed.
    78         I $D(BSDXMSG) D ERR(BSDXI,"3~BSDX26: Fileman failure to file data into 9002018.4") QUIT
    79         ;
    80         ; Now file in file 44:
    81         N PTIEN S PTIEN=$$GET1^DIQ(9002018.4,BSDXAPTID,".05","I") ; Patient IEN
    82         N HLIEN S HLIEN=$$GET1^DIQ(9002018.4,BSDXAPTID,".07:.04","I") ; HL Location IEN pointed to by Resource ID
    83         N DATE S DATE=+^BSDXAPPT(BSDXAPTID,0) ; Date of APPT
    84         N BSDXRES S BSDXRES=0 ; Result
    85         ; Update Note only if we have a linked hospital location.
    86         I HLIEN S BSDXRES=$$UPDATENT^BSDXAPI1(PTIEN,HLIEN,DATE,BSDXNOTE(.5))
    87         ; If we get an error (denoted by -1 in BSDXRES), return error to client
    88         ; AND restore the original note
    89         I BSDXRES D ERR(BSDXI,"4~BSDX26: BSDXAPI reports an error: "_BSDXRES),ROLLBACK(BSDXAPTID) QUIT
    90         ;
    91         ;Return Recordset indicating success
    92         L -^BSDXAPPT(BSDXAPTID)
    93         S BSDXI=BSDXI+1
    94         S ^BSDXTMP($J,BSDXI)="-1"_$C(30)
    95         S BSDXI=BSDXI+1
    96         S ^BSDXTMP($J,BSDXI)=$C(31)
    97         ;
    98         K ^TMP($J) ; Done; remove TMP data
    99         QUIT
    100         ;
    101 ROLLBACK(BSDXAPTID)     ; Rollback note to original in ^BSDXAPPT
    102         M ^BSDXAPPT(BSDXAPTID)=^TMP($J,"BEFORE","BSDXAPPT")
    103         K ^TMP($J)
    104         QUIT
    105         ;
     55           ; Called by RPC: BSDX EDIT APPOINTMENT
     56           ;
     57           ; Edits Appointment Text in BSDX APPOINTMENT file & Hosp Location (44) file
     58           ;
     59           ; Parameters:
     60           ; - BSDXY: Global Return (RPC must be set to Global Array)
     61           ; - BSDXAPTID: Appointment IEN in BSDX APPOINTMENT
     62           ; - BSDXNOTE: New note
     63           ;
     64           ; Return:
     65           ; ADO.net Recordset having 1 field: ERRORID
     66           ; If Okay: -1; otherwise, positive integer with message
     67           ;
     68           ; Return Array; set Return and clear array
     69           S BSDXY=$NA(^BSDXTMP($J))
     70           K ^BSDXTMP($J)
     71           ; ET
     72           N $ET S $ET="G ETRAP^BSDX26"
     73           ; Set up basic DUZ variables
     74           D ^XBKVAR
     75           ; Counter
     76           N BSDXI S BSDXI=0
     77           ; Header Node
     78           S ^BSDXTMP($J,BSDXI)="T00100ERRORID"_$C(30)
     79           ; Restartable txn for GT.M. Restored vars are Params + BSDXI.
     80           TSTART (BSDXY,BSDXAPTID,BSDXNOTE,BSDXI):T="BSDX EDIT APPOINTMENT^BSDX26"
     81           ;
     82           ;;;test for error inside transaction. See if %ZTER works
     83           I $G(bsdxdie) S X=1/0
     84           ;;;test
     85           ;;;test for TRESTART
     86           I $G(bsdxrestart) K bsdxrestart TRESTART
     87           ;;;test
     88           ;
     89           ; Validate Appointment ID
     90           I '+BSDXAPTID D ERR(BSDXI,"-1~BSDX26: Invalid Appointment ID") QUIT
     91           I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"-2~BSDX26: Invalid Appointment ID") QUIT
     92           ; Put the WP in decendant fields from the root to file as a WP field
     93           S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE=""
     94           I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0)
     95           N BSDXMSG ; Message in case of error in filing.
     96           I $D(BSDXNOTE(.5)) D
     97           . D WP^DIE(9002018.4,BSDXAPTID_",",1,"","BSDXNOTE","BSDXMSG")
     98           I $D(BSDXMSG) D ERR(BSDXI,"-3~BSDX26: Fileman failure to file data into 9002018.4") QUIT
     99           ;
     100           ; Now file in file 44:
     101           N PTIEN S PTIEN=$$GET1^DIQ(9002018.4,BSDXAPTID,".05","I") ; Patient IEN
     102           N HLIEN S HLIEN=$$GET1^DIQ(9002018.4,BSDXAPTID,".07:.04","I") ; HL Location IEN pointed to by Resource ID
     103           N DATE S DATE=+^BSDXAPPT(BSDXAPTID,0) ; Date of APPT
     104           N BSDXRES S BSDXRES=0 ; Result
     105           ; Update Note only if we have a linked hospital location.
     106           I HLIEN S BSDXRES=$$UPDATENOTE^BSDXAPI(PTIEN,HLIEN,DATE,BSDXNOTE(.5))
     107           ; If we get an error (denoted by -1 in BSDXRES), return error to client
     108           I BSDXRES<0 D ERR(BSDXI,"-4~BSDX26: BSDXAPI reports an error: "_BSDXRES) QUIT
     109           ;Return Recordset
     110           TCOMMIT
     111           S BSDXI=BSDXI+1
     112           S ^BSDXTMP($J,BSDXI)="-1"_$C(30)
     113           S BSDXI=BSDXI+1
     114           S ^BSDXTMP($J,BSDXI)=$C(31)
     115           QUIT
     116           ;
    106117ERR(BSDXI,BSDXERR)       ;Error processing
    107         ; Unlock first
    108         L:$D(BSDXAPTID) -^BSDXAPPT(BSDXAPTID)
    109         ; If last line is $C(31), we are done. No more errors to send to client.
    110         I ^BSDXTMP($J,$O(^BSDXTMP($J," "),-1))=$C(31) QUIT
    111         S BSDXI=BSDXI+1
    112         S BSDXERR=$TR(BSDXERR,"^","~")
    113         S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
    114         S BSDXI=BSDXI+1
    115         S ^BSDXTMP($J,BSDXI)=$C(31)
    116         QUIT
    117         ;
     118           S BSDXI=BSDXI+1
     119           S BSDXERR=$TR(BSDXERR,"^","~")
     120           I $TL>0 TROLLBACK
     121           S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
     122           S BSDXI=BSDXI+1
     123           S ^BSDXTMP($J,BSDXI)=$C(31)
     124           QUIT
     125           ;
    118126ETRAP     ;EP Error trap entry
    119         N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
    120         D ^%ZTER
    121         ;
    122         I '$D(BSDXI) N BSDXI S BSDXI=0
    123         D ERR(BSDXI,"100~BSDX26 Error: "_$G(%ZTERZE))
    124         QUIT
     127           N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
     128           I $TL>0 TROLLBACK
     129           D ^%ZTER
     130           S $EC=""
     131           I '$D(BSDXI) N BSDXI S BSDXI=0
     132           D ERR(BSDXI,"-100~BSDX26 Error: "_$G(%ZTERZE))
     133           Q
  • Scheduling/trunk/m/BSDX27.m

    r1481 r1563  
    11BSDX27   ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:24am
    2            ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2           ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33           ; Licensed under LGPL
    44           ;
  • Scheduling/trunk/m/BSDX28.m

    r1481 r1563  
    1 BSDX28  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/6/12 10:57am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     1BSDX28  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:25am
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ; Change Log:
     
    3838        . S BSDXRET=BSDXRET_NAME_U_HRN_U_PID_U_DOB_U_BSDXIEN_$C(30)
    3939PID     ;PID Lookup
    40         ; If this ID exists, go get it. If "UJOPID" index doesn't exist,
    41         ; won't work anyways.
    42         I $D(^DPT("UJOPID",BSDXP)) DO  SET BSDXY=BSDXRET_$C(31) QUIT
    43         . S BSDXIEN=$O(^DPT("UJOPID",BSDXP,""))
    44         . Q:'$D(^DPT(BSDXIEN,0))
    45         . S BSDXDPT=$G(^DPT(BSDXIEN,0))
    46         . S BSDXZ=$P(BSDXDPT,U) ;NAME
    47         . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
    48         . I BSDXHRN="" Q  ;NO CHART AT THIS DUZ2
    49         . ; Inactivated Chart get an *
    50         . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q
    51         . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
    52         . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
    53         . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
    54         . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
    55         . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
    56         . S BSDXRET=BSDXRET_BSDXZ_$C(30)
     40           ; If this ID exists, go get it. If "UJOPID" index doesn't exist,
     41           ; won't work anyways.
     42           I $D(^DPT("UJOPID",BSDXP)) DO  SET BSDXY=BSDXRET_$C(31) QUIT
     43           . S BSDXIEN=$O(^DPT("UJOPID",BSDXP,""))
     44           . Q:'$D(^DPT(BSDXIEN,0))
     45           . S BSDXDPT=$G(^DPT(BSDXIEN,0))
     46           . S BSDXZ=$P(BSDXDPT,U) ;NAME
     47           . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
     48           . I BSDXHRN="" Q  ;NO CHART AT THIS DUZ2
     49           . ; Inactivated Chart get an *
     50           . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q
     51           . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
     52           . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
     53           . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
     54           . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
     55           . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
     56           . S BSDXRET=BSDXRET_BSDXZ_$C(30)
    5757        ;
    5858DOB     ;DOB Lookup
     
    7676        . Q
    7777        ;
    78 CHART   ;Chart# Lookup
     78CHART   
     79           ;Chart# Lookup
    7980        I +DUZ(2),BSDXP]"",$D(^AUPNPAT("D",BSDXP)) D  S BSDXY=BSDXRET_$C(31) Q
    8081        . S BSDXIEN=0 F  S BSDXIEN=$O(^AUPNPAT("D",BSDXP,BSDXIEN)) Q:'+BSDXIEN  I $D(^AUPNPAT("D",BSDXP,BSDXIEN,DUZ(2))) D  Q
  • Scheduling/trunk/m/BSDX29.m

    r1481 r1563  
    1 BSDX29  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/9/12 11:50am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     1BSDX29  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:25am
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
     
    88        ; v1.42 by WV/SMH on 3101023
    99        ; - Transaction moved; now restartable too.
     10        ; --> Thanks to Zach Gonzalez and Rick Marshall.
    1011        ; - Refactoring of major portions of routine
    11         ; v1.7 by VEN/SMH on 3120622
    12         ; - Removed transaction code; Locks added in update to prevent concurrent
    13         ;   update
    1412        ;
    1513BSDXCPD(BSDXY,BSDXRES,BSDX44,BSDXBEG,BSDXEND)   ;EP
    1614        ;Entry point for debugging
    1715        ;
    18         ;D DEBUG^%Serenji("BSDXCP^BSDX29(.BSDXY,BSDXRES,BSDX44,BSDXBEG,BSDXEND)")
     16        D DEBUG^%Serenji("BSDXCP^BSDX29(.BSDXY,BSDXRES,BSDX44,BSDXBEG,BSDXEND)")
    1917        Q
    2018        ;
     
    2422           ;Called by RPC: BSDX COPY APPOINTMENTS
    2523        ;
    26         ; Parameters:
    27         ; - BSDXY: Global Return
    28         ; - BSDXRES: BSDX RESOURCE to copy appointments to
    29         ; - BSDX44: Hospital Location IEN to copy appointments from
    30         ; - BSDXBEG: Beginning Date in FM Format
    31         ; - BSDXEND: End Date in FM Format
    32         ;
     24           ; Parameters:
     25           ; - BSDXY: Global Return
     26           ; - BSDXRES: BSDX RESOURCE to copy appointments to
     27           ; - BSDX44: Hospital Location IEN to copy appointments from
     28           ; - BSDXBEG: Beginning Date in FM Format
     29           ; - BSDXEND: End Date in FM Format
     30           ;
    3331        ;Returns ADO Recordset containing TASK_NUMBER and ERRORID
    3432        ;
    35         ; Return Array
     33           ; Return Array
    3634        S BSDXY=$NA(^BSDXTMP($J))
    37         K ^BSDXTMP($J)
    38         ; $ET
    39         N $ET S $ET="G ETRAP^BSDX29"
     35           K ^BSDXTMP($J)
     36           ; $ET
     37           N $ET S $ET="G ETRAP^BSDX29"
    4038        ; Counter
    41         N BSDXI S BSDXI=0
    42         ; Header Node
     39           N BSDXI S BSDXI=0
     40           ; Header Node
    4341        S ^BSDXTMP($J,0)="T00010TASK_NUMBER^T00100ERRORID"_$C(30)
    4442        ;
    45         ; Make dates inclusive; add 1 to FM dates
    46         S BSDXBEG=$$FMADD^XLFDT(BSDXBEG,-1)
    47         S BSDXEND=$$FMADD^XLFDT(BSDXEND,+1)
    48         ;
    49         ; Taskman variables
    50         N ZTSK,ZTRTN,ZTDTH,ZTDESC,ZTSAVE,ZTIO
     43           ; Make dates inclusive; add 1 to FM dates
     44           S BSDXBEG=BSDXBEG-1
     45        S BSDXEND=BSDXEND+1
     46        ;
     47           ; Taskman variables
     48           N ZTSK,ZTRTN,ZTDTH,ZTDESC,ZTSAVE
    5149        ; Task Load
    52         S ZTRTN="ZTM^BSDX29",ZTDTH=$H,ZTDESC="COPY PATIENT APPTS",ZTIO=""
     50        S ZTRTN="ZTM^BSDX29",ZTDTH=$H,ZTDESC="COPY PATIENT APPTS"
    5351        S ZTSAVE("BSDXBEG")="",ZTSAVE("BSDXEND")="",ZTSAVE("BSDX44")="",ZTSAVE("BSDXRES")=""
    5452        D ^%ZTLOAD
     
    6462        ;
    6563ZTM     ;EP - Taskman entry point
    66         ; Variables set up in ZTSAVE above
    67         ;
     64           ; Variables set up in ZTSAVE above
     65           ;
    6866        Q:'$D(ZTSK)
    69         ;
    70         ; $ET
    71         N $ET S $ET="G ZTMERR^BSDX29"
    72         ;
     67           ; $ET
     68           N $ET S $ET="G ZTMERR^BSDX29"
     69        ; Txn
     70           TSTART (BSDXBEG,BSDXEND,BSDX44,BSDXRES):T="BSDX COPY APPOINTMENT^BSDX29"
    7371        ;$O through ^SC(BSDX44,"S",
    7472        N BSDXCNT S BSDXCNT=0  ; Count of Copied Appointments
    75         N BSDXQUIT S BSDXQUIT=0  ; Quit Flag to be retrieved from an external proc
     73           N BSDXQUIT S BSDXQUIT=0  ; Quit Flag to be retrieved from an external proc
    7674        ; Set Count
    77         S ^BSDXTMP("BSDXCOPY",ZTSK)=BSDXCNT
     75           S ^BSDXTMP("BSDXCOPY",ZTSK)=BSDXCNT
    7876        ; Loop through dates here.
    79         F  S BSDXBEG=$O(^SC(BSDX44,"S",BSDXBEG)) Q:'+BSDXBEG  Q:BSDXBEG>BSDXEND  Q:BSDXQUIT  D
    80         . ; Loop through Entries in each date in the subsubfile.
    81         . ; Quit if we are at the end or if a remote process requests a quit.
    82         . N BSDXIEN S BSDXIEN=0
     77           F  S BSDXBEG=$O(^SC(BSDX44,"S",BSDXBEG)) Q:'+BSDXBEG  Q:BSDXBEG>BSDXEND  Q:BSDXQUIT  D
     78           . ; Loop through Entries in each date in the subsubfile.
     79           . ; Quit if we are at the end or if a remote process requests a quit.
     80           . N BSDXIEN S BSDXIEN=0
    8381        . F  S BSDXIEN=$O(^SC(BSDX44,"S",BSDXBEG,1,BSDXIEN)) Q:'+BSDXIEN  Q:BSDXQUIT  D
    8482        . . N BSDXNOD S BSDXNOD=$G(^SC(BSDX44,"S",BSDXBEG,1,BSDXIEN,0)) ; Node
    8583        . . Q:'+BSDXNOD  ; Quit if no node
    8684        . . N BSDXCAN S BSDXCAN=$P(BSDXNOD,U,9) ; Cancel flag
    87         . . Q:BSDXCAN="C"  ; Quit if appt cancelled -- smh - this will never happen; cancelled appointments are normally removed from 44
    88         . . N BSDXPAT S BSDXPAT=$P(BSDXNOD,U) ; Patient
    89         . . N BSDXLEN S BSDXLEN=$P(BSDXNOD,U,2) ;duration in minutes
     85        . . Q:BSDXCAN="C"  ; Quit if appt cancelled
     86           . . N BSDXPAT S BSDXPAT=$P(BSDXNOD,U) ; Patient
     87           . . N BSDXLEN S BSDXLEN=$P(BSDXNOD,U,2) ;duration in minutes
    9088        . . N BSDXCLRK S BSDXCLRK=$P(BSDXNOD,U,6) ;appt made by (clerk)
    9189        . . N BSDXMADE S BSDXMADE=$P(BSDXNOD,U,7) ;date appt made
     
    9391        . . S BSDXCNT=BSDXCNT+$$XFER(BSDXRES,BSDXBEG,BSDXPAT,BSDXLEN,BSDXCLRK,BSDXMADE,BSDXNOTE)
    9492        . . I +BSDXCNT,BSDXCNT#10=0 S ^BSDXTMP("BSDXCOPY",ZTSK)=BSDXCNT_" records copied." ;every 10th record
    95         . . I $D(^BSDXTMP("BSDXCOPY",ZTSK,"CANCEL")) S BSDXQUIT=1 ;Check for cancel flag ; smh - not used currently (v1.7)
    96         ;
    97         ;
     93        . . I $D(^BSDXTMP("BSDXCOPY",ZTSK,"CANCEL")) S BSDXQUIT=1 ;Check for cancel flag
     94        . . Q
     95        . Q
     96        I 'BSDXQUIT TCOMMIT
     97        E  TROLLBACK
    9898        S ^BSDXTMP("BSDXCOPY",ZTSK)=$S(BSDXQUIT:"Cancelled.  No records copied.",1:"Finished.  "_BSDXCNT_" records copied.")
    9999        Q
     
    101101ZTMERR  ; For now, error from TM is only in trap; not returned to client.
    102102        N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
     103           ; Rollback before logging the error
     104           I $TL>0 TROLLBACK
    103105        D ^%ZTER
     106           S $EC="" ; Clear Error
    104107        QUIT
    105108        ;
     
    109112        ;Return 1 if record copied, otherwise 0
    110113        ;
    111         N REF
    112         S REF=$NA(^BSDXLOCK(BSDXRES,BSDXBEG,BSDXPAT)) ; This combo is unique
    113         L +@REF:0  E  Q 0
    114         ;
    115114        ;$O Thru ^BSDXAPPT to determine if this appt already added
    116         N BSDXEND,BSDXIEN,BSDXFND,BSDXPAT2,BSDXNOD
     115        N BSDXEND,BSDXIEN,BSDXFND,BSDXPAT2
    117116        S BSDXIEN=0,BSDXFND=0
    118117        F  S BSDXIEN=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXBEG,BSDXIEN)) Q:'+BSDXIEN  D  Q:BSDXFND
     
    123122        . I BSDXPAT2=BSDXPAT S BSDXFND=1
    124123        . Q
    125         I BSDXFND L -@REF Q 0
     124        Q:BSDXFND 0
    126125        ;
    127126        ;Add to BSDX APPOINTMENT
     
    129128        ;Calculate ending time from beginning time and duration.
    130129        S BSDXEND=$$ADDMIN(BSDXBEG,BSDXLEN)
    131         N BSDXFDA,BSDXIENS
    132130        S BSDXIENS="+1,"
    133131        S BSDXFDA(9002018.4,BSDXIENS,.01)=BSDXBEG
     
    139137        ;
    140138        K BSDXIEN
    141         ;
    142139        D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
    143140        S BSDXIEN=+$G(BSDXIEN(1))
    144         I '+BSDXIEN L -@REF Q 0
     141        I '+BSDXIEN Q 0
    145142        ;
    146143        ;Add WP field
    147144        I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE="" D
    148145        . D WP^DIE(9002018.4,BSDXIEN_",",1,"","BSDXNOTE","BSDXMSG")
    149         L -@REF
    150146        ;
    151147        Q 1
    152148        ;
    153149ERR(BSDXI,BSDXCNT,BSDXERR)      ;Error processing
    154         ; If last line is $C(31), we are done. No more errors to send to client.
    155         I ^BSDXTMP($J,$O(^BSDXTMP($J," "),-1))=$C(31) QUIT
    156         S BSDXI=BSDXI+1
    157         S BSDXERR=$TR(BSDXERR,"^","~")
     150        S BSDXI=BSDXI+1
     151           S BSDXERR=$TR(BSDXERR,"^","~")
    158152        S ^BSDXTMP($J,BSDXI)=BSDXCNT_"^"_BSDXERR_$C(30)
    159153        S BSDXI=BSDXI+1
     
    163157ETRAP   ;EP Error trap entry
    164158        ; No Txn here. So don't rollback anything
    165         N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
    166         D ^%ZTER
    167         S $EC="" ; Clear error
     159           N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
     160           D ^%ZTER
     161           S $EC="" ; Clear error
    168162        I '$D(BSDXI) N BSDXI S BSDXI=0
    169163        D ERR(BSDXI,$G(BSDXCNT),"~100~BSDX29, Error: "_$G(%ZTERZE))
  • Scheduling/trunk/m/BSDX2E.m

    r1481 r1563  
    1 BSDX2E  ;IHS/OIT/MJL - ENVIRONMENT CHECK FOR WINDOWS SCHEDULING [7/11/12 9:37am]
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     1BSDX2E  ;IHS/OIT/MJL - ENVIRONMENT CHECK FOR WINDOWS SCHEDULING [4/28/11 10:28am]
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
     
    2424        Q:'$$VERCHK("SD",5.3)
    2525        ; Q:'$$PATCHCK("PIMS*5.3*1003") D
    26         Q:'$$VERCHK("BMX",4)
     26        Q:'$$VERCHK("BMX",2)
    2727        ;
    2828OTHER   ;
     
    9191        . D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
    9292        . ; Error message
    93         . I $D(BSDXMSG) D MES^XPDUTL("Error: ",BSDXMSG("DIERR",1,"TEXT",1))
     93        . I $D(BSDXMSG) W $C(7),"Error: ",BSDXMSG("DIERR",1,"TEXT",1)
    9494        ;
    9595        ; Remove nassssty protocols ORU PATIENT MOVMT and DVBA C&P SCHD EVENT
     
    106106        D:$D(BSDXFDA) FILE^DIE("","BSDXFDA","BSDXMSG")
    107107        ; If error
    108         I $D(BSDXMSG) D MES^XPDUTL("Error: ",BSDXMSG("DIERR",1,"TEXT",1))
     108        I $D(BSDXMSG) W $C(7),"Error: ",BSDXMSG("DIERR",1,"TEXT",1)
    109109        ;
    110110        ;
     
    117117        I $G(BSDXERR) W $C(7),"Error: ",BSDXERR
    118118        D PUT^XPAR("PKG","BSDX AUTO PRINT AS",1,0,.BSDXERR)
    119         I $G(BSDXERR) D MES^XPDUTL("Error: ",BSDXERR)
     119        I $G(BSDXERR) W $C(7),"Error: ",BSDXERR
    120120        QUIT
    121121        ;
  • Scheduling/trunk/m/BSDX30.m

    r1481 r1563  
    1 BSDX30  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; [7/6/12 11:03am]
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     1BSDX30  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; [4/28/11 10:28am]
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
     
    77        ;Entry point for debugging
    88        ;
    9         ; D DEBUG^%Serenji("SPACE^BSDX30(.BSDXY,BSDXDIC,BSDXVAL)")
     9        D DEBUG^%Serenji("SPACE^BSDX30(.BSDXY,BSDXDIC,BSDXVAL)")
    1010        Q
    1111        ;
     
    4949EHRPTD(BSDXY,BSDXWID,BSDXDFN)   ;
    5050        ;
    51         ; D DEBUG^%Serenji("EHRPT^BSDX30(.BSDXY,BSDXWID,BSDXDFN)")
     51        D DEBUG^%Serenji("EHRPT^BSDX30(.BSDXY,BSDXWID,BSDXDFN)")
    5252        Q
    5353        ;
     
    7070        ;
    7171PEVENT(BSDXWID,DFN)     ;EP - Raise patient selection event to EHR
    72         ; VEN/SMH v1.7 3120706 - Not used in VISTA.
    73         ; No way right now to synchronize with CPRS.
    74         ; Code commented out for now.
    7572        ;
    7673        ;Change patient context to patient DFN
     
    8178        ;all EHR client sessions belonging to user DUZ.
    8279        ;
    83         ;Q:'$G(DUZ)
     80        Q:'$G(DUZ)
    8481        ;N X
    8582        ;S X="CIANBUTL" X ^%ZOSF("TEST") Q:'$T
    8683        ;S X="CIANBEVT" X ^%ZOSF("TEST") Q:'$T
    87         ;N UID,BRET
    88         ;S BRET=0,UID=0
    89         ;F  S BRET=$$NXTUID^CIANBUTL(.UID,1) Q:'UID  D
    90         ;. Q:DUZ'=$$GETVAR^CIANBUTL("DUZ",,,UID)
    91         ;. I BSDXWID'="" Q:BSDXWID'=$TR($$GETVAR^CIANBUTL("WID",,,UID),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    92         ;. D QUEUE^CIANBEVT("CONTEXT.PATIENT",+DFN,UID)
    93         ;Q
     84        N UID,BRET
     85        S BRET=0,UID=0
     86        F  S BRET=$$NXTUID^CIANBUTL(.UID,1) Q:'UID  D
     87        . Q:DUZ'=$$GETVAR^CIANBUTL("DUZ",,,UID)
     88        . I BSDXWID'="" Q:BSDXWID'=$TR($$GETVAR^CIANBUTL("WID",,,UID),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     89        . D QUEUE^CIANBEVT("CONTEXT.PATIENT",+DFN,UID)
     90        Q
  • Scheduling/trunk/m/BSDX31.m

    r1481 r1563  
    1 BSDX31   ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/10/12 10:39am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
    3         ; Licensed under LGPL
    4         ; Change Log:
    5         ; v1.42 3101023 WV/SMH - Change transaction to restartable.
    6         ; v1.42 3101206 UJO/SMH - Extensive refactoring
    7         ; v1.7  3120626 VEN/SMH - Removed transactions; extensive refactoring
    8         ;                       - Moved APTNS (whatever it was) to BSDXAPI1
    9         ;                         as $$NOSHOW
    10         ;                       - Made BSDXNOS extrinsic.
    11         ;                       - Moved Unit Tests to BSDXUT1
    12         ;                       - BSDXNOS deletes no-show rather than file 0 for
    13         ;                         undoing a no show
    14         ;
    15         ; Error Reference:
    16         ; -1: zero or null Appt ID
    17         ; -2: Invalid APPT ID (doesn't exist in ^BSDXAPPT)
    18         ; -3: No-show flag is invalid
    19         ; -4: Filing of No-show in ^BSDXAPPT failed
    20         ; -5: Filing of No-show in ^DPT failed (BSDXAPI error)
    21         ; -6: Invalid Resource ID
    22         ; -7: Lock not acquired on ^BSDXAPPT(BSDXAPTID)
    23         ; -100: M Error
    24         ;
    25         ;
     1BSDX31   ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:28am
     2           ;;1.6;BSDX;;Aug 31, 2011;Build 25
     3           ; Licensed under LGPL
     4           ; Change Log:
     5           ; v1.42 Oct 23 2010 WV/SMH
     6           ; - Change transaction to restartable. Thanks to Zach Gonzalez
     7           ; --> and Rick Marshall for their help.
     8           ; v1.42 Dec 6 2010: Extensive refactoring
     9           ;
     10           ; Error Reference:
     11           ; -1: zero or null Appt ID
     12           ; -2: Invalid APPT ID (doesn't exist in ^BSDXAPPT)
     13           ; -3: No-show flag is invalid
     14           ; -4: Filing of No-show in ^BSDXAPPT failed
     15           ; -5: Filing of No-show in ^DPT failed (BSDXAPI error)
     16           ; -100: M Error
     17           ;
     18           ;
    2619NOSHOWD(BSDXY,BSDXAPTID,BSDXNS) ;EP
    27         ;Entry point for debugging
    28         ;
    29         ; D DEBUG^%Serenji("NOSHOW^BSDX31(.BSDXY,BSDXAPTID,BSDXNS)")
    30         Q
    31         ;
     20           ;Entry point for debugging
     21           ;
     22           D DEBUG^%Serenji("NOSHOW^BSDX31(.BSDXY,BSDXAPTID,BSDXNS)")
     23           Q
     24           ;
     25UT      ; Unit Tests
     26           ; Test 1: Sanity Check
     27           N ZZZ ; Garbage return variable
     28           N DATE S DATE=$$NOW^XLFDT()
     29           S DATE=$E(DATE,1,12) ; Just get minutes b/c of HL file input transform
     30           D APPADD^BSDX07(.ZZZ,DATE,DATE+.0001,3,"Dr Office",30,"Old Note",1)
     31           N APPID S APPID=+$P(^BSDXTMP($J,1),U)
     32           D NOSHOW(.ZZZ,APPID,1)
     33           I $P(^BSDXAPPT(APPID,0),U,10)'=1 W "ERROR T1",! B
     34           I $P(^DPT(3,"S",DATE,0),U,2)'="N" W "ERROR T1",! B
     35           ; Test 2: Undo noshow
     36           D NOSHOW(.ZZZ,APPID,0)
     37           I $P(^BSDXAPPT(APPID,0),U,10)'="0" W "ERROR T2",! B
     38           I $P(^DPT(3,"S",DATE,0),U,2)'="" W "ERROR T2",! B
     39           ; Test 3: -1
     40           D NOSHOW(.ZZZ,"",0)
     41           I $P(^BSDXTMP($J,1),U)'=-1 W "ERROR T3",! B
     42           ; Test 4: -2
     43           D NOSHOW(.ZZZ,2938748233,0)
     44           I $P(^BSDXTMP($J,1),U)'=-2 W "ERROR T4",! B
     45           ; Test 5: -3
     46           D NOSHOW(.ZZZ,APPID,3)
     47           I $P(^BSDXTMP($J,1),U)'=-3 W "ERROR T5",! B
     48           ; Test 6: Mumps error (-100)
     49           s bsdxdie=1
     50           D NOSHOW(.ZZZ,APPID,1)
     51           I $P(^BSDXTMP($J,1),U)'=-100 W "ERROR T6",! B
     52           k bsdxdie
     53           ; Test 7: Restartable transaction
     54           s bsdxrestart=1
     55           D NOSHOW(.ZZZ,APPID,1)
     56           I $P(^BSDXAPPT(APPID,0),U,10)'=1 W "ERROR T7",! B
     57           QUIT
    3258NOSHOW(BSDXY,BSDXAPTID,BSDXNS)          ;EP - No show a patient
    33         ; Called by RPC: BSDX NOSHOW
    34         ; Sets appointment noshow flag in BSDX APPOINTMENT file and "S" node in File 2
    35         ;
    36         ; Parameters:
    37         ; BSDXY: Global Return
    38         ; BSDXAPTID is entry number in BSDX APPOINTMENT file
    39         ; BSDXNS = 1: NOSHOW, 0: CANCEL NOSHO
    40         ;
    41         ; Returns ADO.net record set with fields
    42         ; - ERRORID; ERRORTEXT
    43         ; ERRORID of 1 is okay
    44         ; Anything else is an error.
    45         ;
    46         ; Return Array; set and clear
    47         S BSDXY=$NA(^BSDXTMP($J))
    48         K ^BSDXTMP($J)
    49         ;
    50         ; $ET
    51         N $ET S $ET="G ETRAP^BSDX31"
    52         ;
    53         ; Basline vars
    54         D ^XBKVAR  ; Set up baseline variables (DUZ, DUZ(2)) if they don't exist
    55         ;
    56         ; Counter
    57         N BSDXI S BSDXI=0
    58         ;
    59         ; Header Node
    60         S ^BSDXTMP($J,BSDXI)="I00100ERRORID^T00030ERRORTEXT"_$C(30)
    61         ;
    62         ;;;test for error. See if %ZTER works
    63         I $G(BSDXDIE) N X S X=1/0
    64         ;;;TEST
    65         ;
    66         ; Turn off SDAM APPT PROTOCOL BSDX Entries
    67         N BSDXNOEV S BSDXNOEV=1 ;Don't execute protocol
    68         ;
    69         ; Appointment ID check
    70         I '+BSDXAPTID D ERR(-1,"BSDX31: Invalid Appointment ID") Q
    71         I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(-2,"BSDX31: Invalid Appointment ID") Q
    72         ;
    73         ; Lock BSDX node, only to synchronize access to the globals.
    74         ; It's not expected that the error will ever happen as no filing
    75         ; is supposed to take 5 seconds.
    76         L +^BSDXAPPT(BSDXAPTID):5 E  D ERR(-7,"BSDX31: Appt record is locked. Please contact technical support.") Q
    77         ;
    78         ; Noshow value check - Must be 1 or 0
    79         S BSDXNS=+BSDXNS
    80         I BSDXNS'=1&(BSDXNS'=0) D ERR(-3,"BSDX31: Invalid No Show value") Q
    81         ;
    82         ; Get Some data
    83         N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPTID,0) ; Node
    84         N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; DFN
    85         N BSDXSTART S BSDXSTART=$P(BSDXNOD,U)  ; Start Date/Time
    86         N BSDXRES S BSDXRES=$P(BSDXNOD,U,7) ; Resource ID
    87         ;
    88         ; Check if Resource ID is missing or invalid
    89         I BSDXRES="" D ERR(-6,"BSDX31: Invalid Resource") QUIT
    90         I '$D(^BSDXRES(BSDXRES,0)) D ERR(-6,"BSDX31: Invalid Resource") QUIT
    91         ;
    92         ; Get the Hospital Location
    93         N BSDXRESNOD S BSDXRESNOD=^BSDXRES(BSDXRES,0)
    94         N BSDXLOC S BSDXLOC=$P(BSDXRESNOD,U,4) ;HOSPITAL LOCATION
    95         I BSDXLOC,'$D(^SC(BSDXLOC,0)) S BSDXLOC="" ; Unlink it if it doesn't exist
    96         ; I can go and then delete it from ^BSDXRES like Mailman code which tries
    97         ; to be too helpful... but I will postpone that until this is a need.
    98         ;
    99         ; Check if it's okay to no-show patient.
    100         N BSDXERR S BSDXERR=0 ; Error variable
    101         I BSDXLOC S BSDXERR=$$NOSHOWCK^BSDXAPI1(BSDXPATID,BSDXLOC,BSDXSTART,BSDXNS)
    102         I BSDXERR D ERR(-5,"BSDX31: "_$P(BSDXERR,U,2)) QUIT
    103         ;
    104         ; Simulated Error
    105         I $G(BSDXSIMERR1) D ERR(-4,"BSDX31: Simulated Error") QUIT
    106         ; Edit BSDX APPOINTMENT entry No-show field
    107         ; Failure Analysis: If we fail here, no rollback needed, as this is the 1st
    108         ; call
    109         N BSDXMSG S BSDXMSG=$$BSDXNOS(BSDXAPTID,BSDXNS)
    110         I BSDXMSG D ERR(-4,"BSDX31: "_$P(BSDXMSG,U,2)) QUIT
    111         ;
    112         ; Edit File 2 "S" node entry
    113         ; Failure Analysis: If we fail here, we need to rollback the BSDX
    114         ; Apptointment Entry
    115         N BSDXERR S BSDXERR=0 ; Error variable
    116         ; If HL exist, (resource is linked to PIMS), file no show in File 2
    117         I BSDXLOC S BSDXERR=$$NOSHOW^BSDXAPI1(BSDXPATID,BSDXLOC,BSDXSTART,BSDXNS)
    118         I BSDXERR D  QUIT
    119         . D ERR(-5,"BSDX31: "_$P(BSDXERR,U,2))
    120         . N % S %=$$BSDXNOS(BSDXAPTID,'BSDXNS) ; no error checking for filer
    121         ;
    122         ; Unlock
    123         L -^BSDXAPPT(BSDXAPTID)
    124         ;
    125         ; Return data in ADO.net table
    126         S BSDXI=BSDXI+1
    127         S ^BSDXTMP($J,BSDXI)="1^"_$C(30) ; 1 means everything okay
    128         S BSDXI=BSDXI+1
    129         S ^BSDXTMP($J,BSDXI)=$C(31)
    130         QUIT
    131         ;
    132 BSDXNOS(BSDXAPTID,BSDXNS)       ; $$ Private; File/unfile noshow in ^BSDXAPPT
    133         ; in v1.7 I delete the no-show value rather than file zero
    134         N BSDXFDA,BSDXIENS,BSDXMSG
    135         N BSDXVALUE ; What to file: 1 or delete it.
    136         I BSDXNS S BSDXVALUE=1
    137         E  S BSDXVALUE="@"
    138         S BSDXIENS=BSDXAPTID_","
    139         S BSDXFDA(9002018.4,BSDXIENS,.1)=BSDXVALUE ;NOSHOW 1 or 0
    140         D FILE^DIE("","BSDXFDA","BSDXMSG")
    141         QUIT:$D(BSDXMSG) -1_U_BSDXMSG("DIERR",1,"TEXT",1)
    142         QUIT 0
    143         ;
     59           ; Called by RPC: BSDX NOSHOW
     60           ; Sets appointment noshow flag in BSDX APPOINTMENT file and "S" node in File 2
     61           ;
     62           ; Parameters:
     63           ; BSDXY: Global Return
     64           ; BSDXAPTID is entry number in BSDX APPOINTMENT file
     65           ; BSDXNS = 1: NOSHOW, 0: CANCEL NOSHO
     66           ;
     67           ; Returns ADO.net record set with fields
     68           ; - ERRORID; ERRORTEXT
     69           ; ERRORID of 1 is okay
     70           ; Anything else is an error.
     71           ;
     72           ; Return Array; set and clear
     73           S BSDXY=$NA(^BSDXTMP($J))
     74           K ^BSDXTMP($J)
     75           ; $ET
     76           N $ET S $ET="G ETRAP^BSDX31"
     77           ; Basline vars
     78           D ^XBKVAR  ; Set up baseline variables (DUZ, DUZ(2)) if they don't exist
     79           ; Counter
     80           N BSDXI S BSDXI=0
     81           ; Header Node
     82           S ^BSDXTMP($J,BSDXI)="I00100ERRORID^T00030ERRORTEXT"_$C(30)
     83           ; Begin transaction
     84           TSTART (BSDXI,BSDXY,BSDXAPTID,BSDXNS):T="BSDX NOSHOW CANCEL^BSDX29"
     85           ;;;test for error inside transaction. See if %ZTER works
     86           I $G(bsdxdie) S X=1/0
     87           ;;;TEST
     88           ;;;test for TRESTART
     89           I $G(bsdxrestart) K bsdxrestart TRESTART
     90           ;;;test
     91           ; Turn off SDAM APPT PROTOCOL BSDX Entries
     92           N BSDXNOEV S BSDXNOEV=1 ;Don't execute protocol
     93           ; Appointment ID check
     94           I '+BSDXAPTID D ERR(-1,"BSDX31: Invalid Appointment ID") Q
     95           I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(-2,"BSDX31: Invalid Appointment ID") Q
     96           ; Noshow value check - Must be 1 or 0
     97           S BSDXNS=+BSDXNS
     98           I BSDXNS'=1&(BSDXNS'=0) D ERR(-3,"BSDX31: Invalid No Show value") Q
     99           ; Get Some data
     100           N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPTID,0) ; Node
     101           N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; DFN
     102           N BSDXSTART S BSDXSTART=$P(BSDXNOD,U)  ; Start Date/Time
     103           ; Edit BSDX APPOINTMENT entry
     104           N BSDXMSG  ;
     105           D BSDXNOS(BSDXAPTID,BSDXNS,.BSDXMSG)  ;Edit BSDX APPOINTMENT entry NOSHOW field
     106           I $D(BSDXMSG("DIERR")) S BSDXMSG=$G(BSDXMSG("DIERR",1,"TEXT",1)) D ERR(-4,"BSDX31: "_BSDXMSG) Q
     107           ; Edit File 2 "S" node entry
     108           N BSDXZ,BSDXERR ; Error variables to control looping
     109           S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID
     110           ; If Resource ID exists, and HL exists (means that Resource is linked), No show in File 2
     111           I BSDXSC1]"",$D(^BSDXRES(BSDXSC1,0)) D  I $G(BSDXZ)]"" S BSDXERR="BSDX31: APNOSHO Returned: "_BSDXZ D ERR(-5,BSDXERR) Q
     112           . S BSDXNOD=^BSDXRES(BSDXSC1,0)
     113           . S BSDXSC1=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION
     114           . I BSDXSC1]"",$D(^SC(BSDXSC1,0)) D APNOSHO(.BSDXZ,BSDXSC1,BSDXPATID,BSDXSTART,BSDXNS)
     115           ;
     116           TCOMMIT
     117           S BSDXI=BSDXI+1
     118           S ^BSDXTMP($J,BSDXI)="1^"_$C(30) ; 1 means everything okay
     119           S BSDXI=BSDXI+1
     120           S ^BSDXTMP($J,BSDXI)=$C(31)
     121           QUIT
     122           ;
     123APNOSHO(BSDXZ,BSDXSC1,BSDXDFN,BSDXSD,BSDXNS)               ;
     124           ; update file 2 info
     125           ;Set noshow for patient BSDXDFN in clinic BSDXSC1
     126           ;at time BSDXSD
     127           N BSDXC,%H,BSDXCDT,BSDXIEN
     128           N BSDXIENS,BSDXFDA,BSDXMSG
     129           S %H=$H D YMD^%DTC
     130           S BSDXCDT=X+%
     131           ;
     132           S BSDXIENS=BSDXSD_","_BSDXDFN_","
     133           I +BSDXNS D
     134           . S BSDXFDA(2.98,BSDXIENS,3)="N"
     135           . S BSDXFDA(2.98,BSDXIENS,14)=DUZ
     136           . S BSDXFDA(2.98,BSDXIENS,15)=BSDXCDT
     137           E  D
     138           . S BSDXFDA(2.98,BSDXIENS,3)=""
     139           . S BSDXFDA(2.98,BSDXIENS,14)=""
     140           . S BSDXFDA(2.98,BSDXIENS,15)=""
     141           K BSDXIEN
     142           D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
     143           S BSDXZ=$G(BSDXMSG("DIERR",1,"TEXT",1))
     144           Q
     145           ;
     146BSDXNOS(BSDXAPTID,BSDXNS,BSDXMSG)         ;
     147           ;
     148           N BSDXFDA,BSDXIENS
     149           S BSDXIENS=BSDXAPTID_","
     150           S BSDXFDA(9002018.4,BSDXIENS,.1)=BSDXNS ;NOSHOW
     151           D FILE^DIE("","BSDXFDA","BSDXMSG")
     152           QUIT
     153           ;
    144154NOSEVT(BSDXPAT,BSDXSTART,BSDXSC)           ;EP Called by BSDX NOSHOW APPOINTMENT event
    145         ;when appointments NOSHOW via PIMS interface.
    146         ;Propagates NOSHOW to BSDXAPPT and raises refresh event to running GUI clients
    147         ;
    148         Q:+$G(BSDXNOEV)
    149         Q:'+$G(BSDXSC)
    150         Q:$G(SDATA("AFTER","STATUS"))["AUTO RE-BOOK"
    151         N BSDXSTAT,BSDXFOUND,BSDXRES
    152         S BSDXSTAT=1
    153         S:$G(SDATA("BEFORE","STATUS"))["NO-SHOW" BSDXSTAT=0
    154         S BSDXFOUND=0
    155         I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) S BSDXFOUND=$$NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
    156         I BSDXFOUND D NOSEVT3(BSDXRES) Q
    157         I $D(^BXDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) S BSDXFOUND=$$NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
    158         I BSDXFOUND D NOSEVT3(BSDXRES)
    159         Q
    160         ;
     155           ;when appointments NOSHOW via PIMS interface.
     156           ;Propagates NOSHOW to BSDXAPPT and raises refresh event to running GUI clients
     157           ;
     158           Q:+$G(BSDXNOEV)
     159           Q:'+$G(BSDXSC)
     160           Q:$G(SDATA("AFTER","STATUS"))["AUTO RE-BOOK"
     161           N BSDXSTAT,BSDXFOUND,BSDXRES
     162           S BSDXSTAT=1
     163           S:$G(SDATA("BEFORE","STATUS"))["NO-SHOW" BSDXSTAT=0
     164           S BSDXFOUND=0
     165           I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0)) S BSDXFOUND=$$NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
     166           I BSDXFOUND D NOSEVT3(BSDXRES) Q
     167           I $D(^BXDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0)) S BSDXFOUND=$$NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)
     168           I BSDXFOUND D NOSEVT3(BSDXRES)
     169           Q
     170           ;
    161171NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)     ;
    162         ;Get appointment id in BSDXAPT
    163         ;If found, call BSDXNOS(BSDXAPPT) and return 1
    164         ;else return 0
    165         N BSDXFOUND,BSDXAPPT,BSDXNOD
    166         S BSDXFOUND=0
    167         Q:'+$G(BSDXRES) BSDXFOUND
    168         Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND
    169         S BSDXAPPT=0 F  S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT  D  Q:BSDXFOUND
    170         . S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
    171         . I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q
    172         I BSDXFOUND,+$G(BSDXAPPT) N BSDXMSG S BSDXMSG=$$BSDXNOS(BSDXAPPT,BSDXSTAT)
    173         I BSDXMSG D ^%ZTER ; Last ditch error handling. This is supposed to be silently called from the protocol file.
    174         Q BSDXFOUND
    175         ;
     172           ;Get appointment id in BSDXAPT
     173           ;If found, call BSDXNOS(BSDXAPPT) and return 1
     174           ;else return 0
     175           N BSDXFOUND,BSDXAPPT
     176           S BSDXFOUND=0
     177           Q:'+$G(BSDXRES) BSDXFOUND
     178           Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND
     179           S BSDXAPPT=0 F  S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT  D  Q:BSDXFOUND
     180           . S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
     181           . I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q
     182           I BSDXFOUND,+$G(BSDXAPPT) D BSDXNOS(BSDXAPPT,BSDXSTAT)
     183           Q BSDXFOUND
     184           ;
    176185NOSEVT3(BSDXRES)           ;
    177         ;Call RaiseEvent to notify GUI clients
    178         ;
    179         N BSDXRESN
    180         S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
    181         Q:BSDXRESN=""
    182         S BSDXRESN=$P(BSDXRESN,"^")
    183         D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
    184         Q
    185         ;
    186         ;
     186           ;Call RaiseEvent to notify GUI clients
     187           ;
     188           N BSDXRESN
     189           S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
     190           Q:BSDXRESN=""
     191           S BSDXRESN=$P(BSDXRESN,"^")
     192           D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
     193           Q
     194           ;
     195           ;
    187196ERR(BSDXERID,ERRTXT)       ;Error processing
    188         ; Unlock first
    189         L:$D(BSDXAPTID) -^BSDXAPPT(BSDXAPTID)
    190         ; If last line is $C(31), we are done. No more errors to send to client.
    191         I ^BSDXTMP($J,$O(^BSDXTMP($J," "),-1))=$C(31) QUIT
    192         S BSDXI=BSDXI+1
    193         S ERRTXT=$TR(ERRTXT,"^","~")
    194         S ^BSDXTMP($J,BSDXI)=BSDXERID_"^"_ERRTXT_$C(30)
    195         S BSDXI=BSDXI+1
    196         S ^BSDXTMP($J,BSDXI)=$C(31)
    197         QUIT
    198         ;
     197           S BSDXI=BSDXI+1
     198           S ERRTXT=$TR(ERRTXT,"^","~")
     199           I $TL>0 TROLLBACK
     200           S ^BSDXTMP($J,BSDXI)=BSDXERID_"^"_ERRTXT_$C(30)
     201           S BSDXI=BSDXI+1
     202           S ^BSDXTMP($J,BSDXI)=$C(31)
     203           QUIT
     204           ;
    199205ETRAP     ;EP Error trap entry
    200         N $ET S $ET="D ^%ZTER HALT"  ; Emergency Error Trap
    201         D ^%ZTER
    202         ;
    203         ; Send to client
    204         I '$D(BSDXI) N BSDXI S BSDXI=0
    205         D ERR(-100,"BSDX31 Error: "_$G(%ZTERZE))
    206         Q:$Q 100_U_"Mumps Error" Q
    207         ;
     206           N $ET S $ET="D ^%ZTER HALT"  ; Emergency Error Trap
     207           ; Rollback, otherwise ^XTER will be empty from future rollback
     208           I $TL>0 TROLLBACK
     209           D ^%ZTER
     210           S $EC="" ; Clear Error
     211           ; Send to client
     212           I '$D(BSDXI) N BSDXI S BSDXI=0
     213           D ERR(-100,"BSDX31 Error: "_$G(%ZTERZE))
     214           QUIT
     215           ;
    208216IMHERE(BSDXRES) ;EP
    209         ;Entry point for BSDX IM HERE remote procedure
    210         S BSDXRES=1
    211         Q
    212         ;
     217           ;Entry point for BSDX IM HERE remote procedure
     218           S BSDXRES=1
     219           Q
     220           ;
  • Scheduling/trunk/m/BSDX32.m

    r1481 r1563  
    11BSDX32  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 5/11/11 10:39am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDX33.m

    r1481 r1563  
    11BSDX33  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:29am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL
    44        ; Mods by WV/STAR
  • Scheduling/trunk/m/BSDX34.m

    r1481 r1563  
    11BSDX34  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:29am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL 
    44        ;
  • Scheduling/trunk/m/BSDX35.m

    r1481 r1563  
    1 BSDX35  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 6/21/12 3:57pm
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     1BSDX35  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:29am
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL 
    44        ;
  • Scheduling/trunk/m/BSDXAPI.m

    r1481 r1563  
    1 BSDXAPI ; IHS/LJF,HMW,MAW & VEN/SMH - SCHEDULING APIs ; 7/10/12 5:58pm
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     1BSDXAPI ; IHS/ANMC/LJF & VW/SMH - SCHEDULING APIs ; 4/28/11 10:30am
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL 
    44        ;
    5         ; Orignal routine is BSDAPI by IHS/LJF, HMW, and MAW
    6         ; mods (many) by WV/SMH
    7         ; Move to BSDX namespace as BSDXAPI from BSDAPI by WV/SMH
    8         ; Change history is located in BSDXAPI1 (to save space).
     5        ;Orignal routine is BSDAPI by IHS/LJF, HMW, and MAW
     6        ;local mods (many) by WV/SMH
     7        ;Move to BSDX namespace as BSDXAPI from BSDAPI by WV/SMH
     8        ; Change History:
     9        ; 2010-11-5: (1.42)
     10        ; - Fixed errors having to do uncanceling patient appointments if it was a patient cancelled appointment.
     11        ; - Use new style Fileman API for storing appointments in file 44 in $$MAKE due to problems with legacy API.
     12        ; 2010-11-12: (1.42)
     13        ; - Changed ="C" to ["C" in SCIEN. Cancelled appointments can be "PC" as well.
     14        ; 2010-12-5 (1.42)
     15        ; Added an entry point to update the patient note in file 44.
     16        ; 2010-12-6 (1.42)
     17        ; MAKE1 incorrectly put info field in BSDR("INFO") rather than BSDR("OI")
     18        ; 2010-12-8 (1.42)
     19        ; Removed restriction on max appt length. Even though this restriction
     20        ; exists in fileman (120 minutes), PIMS ignores it. Therefore, I
     21        ; will ignore it here too.
     22        ; 2011-01-25 (v.1.5)
     23        ; Added entry point $$RMCI to remove checked in appointments.
     24        ; In $$CANCEL, if the appointment is checked in, delete check-in rather than
     25        ;  spitting an error message to the user saying 'Delete the check-in'
     26        ; Changed all lines that look like this:
     27        ;  I $G(BSDR("ADT"))'?7N1".".4N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT"))
     28        ; to:
     29        ;  I $G(BSDR("ADT"))'?7N.1".".4N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT"))
     30        ; to allow for date at midnight which does not have a dot at the end.
     31        ; 2011-01-26 (v.1.5)
     32        ; More user friendly message if patient already has appointment in $$MAKE:
     33        ;  Spits out pt name and user friendly date.
     34        ; 
    935        ;
    1036MAKE1(DFN,CLIN,TYP,DATE,LEN,INFO)       ; Simplified PEP w/ parameters for $$MAKE - making appointment
     
    1339        ; for Baby foxes hallucinations.
    1440        ; S RESULT=$$MAKE1^BSDXAPI(23435,33,(3 or 4),3091220.221159,30,"I see Baby foxes")
    15         N BSDR
    1641        S BSDR("PAT")=DFN       ;DFN
    1742        S BSDR("CLN")=CLIN      ;Hosp Loc IEN
     
    4065        ;   = 1^message:  error and reason
    4166        ;
    42         N BSDXMKCK S BSDXMKCK=$$MAKECK(.BSDR) ; Check if we can make appointment
    43         I BSDXMKCK Q BSDXMKCK ; If we can't, quit with the reason why.
    44         ;
    45         ;Otherwise, we continue
    46         ;
    47         N BSDXFDA,BSDXIENS,BSDXMSG ; FILE/UPDATE^DIE variables
    48         ;
    49         I $D(^DPT(BSDR("PAT"),"S",BSDR("ADT"),0)),$P(^(0),U,2)["C" D
    50         . ; "un-cancel" existing appt in file 2
    51         . S BSDXIENS=BSDR("ADT")_","_BSDR("PAT")_","
    52         . S BSDXFDA(2.98,BSDXIENS,".01")=BSDR("CLN")
    53         . S BSDXFDA(2.98,BSDXIENS,"3")=""
    54         . S BSDXFDA(2.98,BSDXIENS,"9")=BSDR("TYP")
    55         . S BSDXFDA(2.98,BSDXIENS,"9.5")=9
    56         . S BSDXFDA(2.98,BSDXIENS,"14")=""
    57         . S BSDXFDA(2.98,BSDXIENS,"15")=""
    58         . S BSDXFDA(2.98,BSDXIENS,"16")=""
    59         . S BSDXFDA(2.98,BSDXIENS,"17")="@" ; v 1.7; cancellation remarks were left over
    60         . S BSDXFDA(2.98,BSDXIENS,"19")=""
    61         . S BSDXFDA(2.98,BSDXIENS,"20")=$$NOW^XLFDT
    62         . D FILE^DIE("","BSDXFDA","BSDXMSG")
    63         Q:$D(BSDXMSG) 1_U_"Fileman edit to DPT error: Patient="_BSDR("PAT")_" Appt="_BSDR("ADT")_" Error="_BSDXMSG("DIERR",1,"TEXT",1)
    64         ;
    65         Q:$G(BSDXSIMERR2) 1_U_$NA(BSDXSIMERR2) ; Unit Test line
    66         ;
    67         E  D  ; File new appointment/edit existing appointment in file 2
    68         . S BSDXIENS="?+2,"_BSDR("PAT")_","
    69         . S BSDXIENS(2)=BSDR("ADT")
    70         . S BSDXFDA(2.98,BSDXIENS,.01)=BSDR("CLN")
    71         . S BSDXFDA(2.98,BSDXIENS,"9")=BSDR("TYP")
    72         . S BSDXFDA(2.98,BSDXIENS,"9.5")=9
    73         . S BSDXFDA(2.98,BSDXIENS,"20")=$$NOW^XLFDT
    74         . D UPDATE^DIE("","BSDXFDA","BSDXIENS","BSDXMSG")
    75         Q:$D(BSDXMSG) 1_U_"FileMan add to DPT error: Patient="_BSDR("PAT")_" Appt="_BSDR("ADT")_" Error="_BSDXMSG("DIERR",1,"TEXT",1)
    76         ;
    77         Q:$G(BSDXSIMERR3) 1_U_$NA(BSDXSIMERR3) ; Unit Test line
    78         ;
    79         ; add appt to file 44. This adds it to the FIRST subfile (Appointment)
    80         N DIC,DA,Y,X,DD,DO,DLAYGO,DINUM
    81         I '$D(^SC(BSDR("CLN"),"S",0)) S ^SC(BSDR("CLN"),"S",0)="^44.001DA^^"
    82         I '$D(^SC(BSDR("CLN"),"S",BSDR("ADT"),0)) D  I Y<1 Q 1_U_"Error adding date to file 44: Clinic="_BSDR("CLN")_" Date="_BSDR("ADT")
    83         . S DIC="^SC("_BSDR("CLN")_",""S"",",DA(1)=BSDR("CLN"),(X,DINUM)=BSDR("ADT")
    84         . S DIC("P")="44.001DA",DIC(0)="L",DLAYGO=44.001
    85         . S Y=1 I '$D(@(DIC_X_")")) D FILE^DICN
    86         ;
    87         Q:$G(BSDXSIMERR4) 1_U_$NA(BSDXSIMERR4) ; Unit Test line
    88         ;
    89         ; add appt for file 44, second subfile (Appointment/Patient)
    90         ; Sep 28 2010: Changed old style API to new style API. Keep for reference //smh
    91         ;K DIC,DA,X,Y,DLAYGO,DD,DO,DINUM
    92         ;S DIC="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
    93         ;S DA(2)=BSDR("CLN"),DA(1)=BSDR("ADT"),X=BSDR("PAT")
    94         ;S DIC("DR")="1///"_BSDR("LEN")_";3///"_$E($G(BSDR("OI")),1,150)_";7///`"_BSDR("USR")_";8///"_$P($$NOW^XLFDT,".")
    95         ;S DIC("P")="44.003PA",DIC(0)="L",DLAYGO=44.003
    96         ;D FILE^DICN
    97         ;
    98         N BSDXIENS S BSDXIENS="?+1,"_BSDR("ADT")_","_BSDR("CLN")_","
    99         N BSDXFDA
    100         S BSDXFDA(44.003,BSDXIENS,.01)=BSDR("PAT")
    101         S BSDXFDA(44.003,BSDXIENS,1)=BSDR("LEN")
    102         S BSDXFDA(44.003,BSDXIENS,3)=$E($G(BSDR("OI")),1,150)
    103         S BSDXFDA(44.003,BSDXIENS,7)=BSDR("USR")
    104         S BSDXFDA(44.003,BSDXIENS,8)=$P($$NOW^XLFDT,".")
    105         N BSDXERR
    106         D UPDATE^DIE("","BSDXFDA","","BSDXERR")
    107         ;
    108         I $D(BSDXERR) Q 1_U_"Error adding appt to file 44: Clinic="_BSDR("CLN")_" Date="_BSDR("ADT")_" Patient="_BSDR("PAT")_" Error: "_BSDXERR("DIERR",1,"TEXT",1)
    109         ;
    110         ;Q:$G(BSDXSIMERR5) 1_U_$NA(BSDXSIMERR5) ; Unit Test line
    111         S:$G(BSDXSIMERR5) X=1/0
    112         ;
    113         ; Update the Availablilities ; Doesn't fail. Global reads and sets.
    114         D AVUPDTMK^BSDXAPI1(BSDR("CLN"),BSDR("ADT"),BSDR("LEN"),BSDR("PAT"))
    115         ;
    116         ; call event driver
    117         NEW DFN,SDT,SDCL,SDDA,SDMODE
    118         S DFN=BSDR("PAT"),SDT=BSDR("ADT"),SDCL=BSDR("CLN"),SDMODE=2
    119         S SDDA=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
    120         D MAKE^SDAMEVT(DFN,SDT,SDCL,SDDA,SDMODE)
    121         Q 0
    122         ;
    123 MAKECK(BSDR)    ; $$ - Is it okay to make an appointment? ; PEP
    124         ; Input: Same as $$MAKE
    125         ; Output: 1^error or 0 for success
    126         ; NB: This subroutine saves no data. Only checks whether it's okay.
    127         ;
    12867        I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))
    12968        I '$D(^SC(+$G(BSDR("CLN")),0)) Q 1_U_"Clinic not on file: "_$G(BSDR("CLN"))
     
    13271        I $G(BSDR("ADT"))'?7N.1".".4N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT"))
    13372        ;
    134         ; Appt Length check removed in v 1.5
    135         ;
     73        ;I ($G(BSDR("LEN"))<5)!($G(BSDR("LEN"))>240) Q 1_U_"Appt Length error: "_$G(BSDR("LEN")) ; v 1.42 - no check on length is done anymore. see top comments for details.
    13674        I '$D(^VA(200,+$G(BSDR("USR")),0)) Q 1_U_"User Who Made Appt Error: "_$G(BSDR("USR"))
    137         ; More verbose error message in v1.5
     75        ;I $D(^DPT(BSDR("PAT"),"S",BSDR("ADT"),0)),$P(^(0),U,2)'["C" Q 1_U_"Patient "_BSDR("PAT")_" already has appt at "_BSDR("ADT") ; v.1.5 more user friendly err msg
     76        ;
    13877        ; Following block to give an error message to user if there is already an appointment for patient. More verbose than others.
    13978        N BSDXERR ; place to store error message
     
    14988        . . N BSDXRESNAM S BSDXRESNAM=$P(^BSDXRES(BSDXRESIEN,0),U)
    15089        . . S BSDXERR=BSDXERR_$C(13,10)_"Scheduling GUI clinic: "_BSDXRESNAM ; tell the user of the BSDX clinic
     90        ;
     91        NEW DIC,DA,Y,X,DD,DO,DLAYGO
     92        ;
     93        I $D(^DPT(BSDR("PAT"),"S",BSDR("ADT"),0)),$P(^(0),U,2)["C" D
     94        . ; "un-cancel" existing appt in file 2
     95        . N BSDXFDA,BSDXIENS,BSDXMSG
     96        . S BSDXIENS=BSDR("ADT")_","_BSDR("PAT")_","
     97        . S BSDXFDA(2.98,BSDXIENS,".01")=BSDR("CLN")
     98        . S BSDXFDA(2.98,BSDXIENS,"3")=""
     99        . S BSDXFDA(2.98,BSDXIENS,"9")=BSDR("TYP")
     100        . S BSDXFDA(2.98,BSDXIENS,"9.5")=9
     101        . S BSDXFDA(2.98,BSDXIENS,"14")=""
     102        . S BSDXFDA(2.98,BSDXIENS,"15")=""
     103        . S BSDXFDA(2.98,BSDXIENS,"16")=""
     104        . S BSDXFDA(2.98,BSDXIENS,"19")=""
     105        . S BSDXFDA(2.98,BSDXIENS,"20")=$$NOW^XLFDT
     106        . D FILE^DIE("","BSDXFDA","BSDXMSG")
     107        . N BSDXTEMP S BSDXTEMP=$G(BSDXMSG)
     108        E  D  I $G(BSDXERR(1)) Q 1_U_"FileMan add to DPT error: Patient="_BSDR("PAT")_" Appt="_BSDR("ADT") 
     109        . N BSDXFDA,BSDXIENS,BSDXMSG
     110        . S BSDXIENS="?+2,"_BSDR("PAT")_","
     111        . S BSDXIENS(2)=BSDR("ADT")
     112        . S BSDXFDA(2.98,BSDXIENS,.01)=BSDR("CLN")
     113        . S BSDXFDA(2.98,BSDXIENS,"9")=BSDR("TYP")
     114        . S BSDXFDA(2.98,BSDXIENS,"9.5")=9
     115        . S BSDXFDA(2.98,BSDXIENS,"20")=$$NOW^XLFDT
     116        . D UPDATE^DIE("","BSDXFDA","BSDXIENS","BSDXERR(1)")
     117        ; add appt to file 44
     118        K DIC,DA,X,Y,DLAYGO,DD,DO
     119        I '$D(^SC(BSDR("CLN"),"S",0)) S ^SC(BSDR("CLN"),"S",0)="^44.001DA^^"
     120        I '$D(^SC(BSDR("CLN"),"S",BSDR("ADT"),0)) D  I Y<1 Q 1_U_"Error adding date to file 44: Clinic="_BSDR("CLN")_" Date="_BSDR("ADT")
     121        . S DIC="^SC("_BSDR("CLN")_",""S"",",DA(1)=BSDR("CLN"),(X,DINUM)=BSDR("ADT")
     122        . S DIC("P")="44.001DA",DIC(0)="L",DLAYGO=44.001
     123        . S Y=1 I '$D(@(DIC_X_")")) D FILE^DICN
     124        ;
     125        ; Sep 28 2010: Changed old style API to new style API. Keep for reference //smh
     126        ;K DIC,DA,X,Y,DLAYGO,DD,DO,DINUM
     127        ;S DIC="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
     128        ;S DA(2)=BSDR("CLN"),DA(1)=BSDR("ADT"),X=BSDR("PAT")
     129        ;S DIC("DR")="1///"_BSDR("LEN")_";3///"_$E($G(BSDR("OI")),1,150)_";7///`"_BSDR("USR")_";8///"_$P($$NOW^XLFDT,".")
     130        ;S DIC("P")="44.003PA",DIC(0)="L",DLAYGO=44.003
     131        ;D FILE^DICN
     132        ;
     133        N BSDXIENS S BSDXIENS="?+1,"_BSDR("ADT")_","_BSDR("CLN")_","
     134        N BSDXFDA
     135        S BSDXFDA(44.003,BSDXIENS,.01)=BSDR("PAT")
     136        S BSDXFDA(44.003,BSDXIENS,1)=BSDR("LEN")
     137        S BSDXFDA(44.003,BSDXIENS,3)=$E($G(BSDR("OI")),1,150)
     138        S BSDXFDA(44.003,BSDXIENS,7)=BSDR("USR")
     139        S BSDXFDA(44.003,BSDXIENS,8)=$P($$NOW^XLFDT,".")
     140        N BSDXERR
     141        D UPDATE^DIE("","BSDXFDA","","BSDXERR")
     142        ;
     143        I $D(BSDXERR) Q 1_U_"Error adding appt to file 44: Clinic="_BSDR("CLN")_" Date="_BSDR("ADT")_" Patient="_BSDR("PAT")_" Error: "_BSDXERR("DIERR",1,"TEXT",1)
     144        ;
     145        ; call event driver
     146        NEW DFN,SDT,SDCL,SDDA,SDMODE
     147        S DFN=BSDR("PAT"),SDT=BSDR("ADT"),SDCL=BSDR("CLN"),SDMODE=2
     148        S SDDA=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
     149        D MAKE^SDAMEVT(DFN,SDT,SDCL,SDDA,SDMODE)
    151150        Q 0
    152         ;
    153 UNMAKE(BSDR)    ; Reverse Make - Private $$
    154         ; Only used in Emergiencies where Fileman data filing fails.
    155         ; If previous data exists, which caused an error, it's destroyed.
    156         ; NB: ^DIK stops for nobody
    157         ; NB: If Patient Appointment previously existed as cancelled, it's removed.
    158         ; How can I tell if one previously existed when data is in an intermediate
    159         ; State? Can I restore it if the other file failed? Restoration can cause
    160         ; another error. If I restore the global, there will be cross-references
    161         ; missing (ASDCN specifically).
    162         ;
    163         ; Input: Same array as $$MAKE
    164         ; Output: Always 0
    165         NEW DIK,DA
    166         S DIK="^DPT("_BSDR("PAT")_",""S"","
    167         S DA(1)=BSDR("PAT"),DA=BSDR("ADT")
    168         D ^DIK
    169         ;
    170         N IEN S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
    171         I 'IEN QUIT 0
    172         ;
    173         NEW DIK,DA
    174         S DIK="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
    175         S DA(2)=BSDR("CLN"),DA(1)=BSDR("ADT"),DA=IEN
    176         D ^DIK
    177         QUIT 0
    178151        ;
    179152CHECKIN1(DFN,CLIN,APDATE)       ; Simplified PEP w/ parameters for $$CHECKIN - Checking in
     
    181154        ; for appt at Dec 20, 2009 @ 10:11:59
    182155        ; S RESULT=$$CHECKIN1^BSDXAPI(23435,33,3091220.221159)
    183         N BSDR
    184156        S BSDR("PAT")=DFN          ;DFN
    185157        S BSDR("CLN")=CLIN         ;Hosp Loc IEN
     
    203175        ;              = 0 means everything worked
    204176        ;              = 1^message means error with reason message
    205         ;
    206         I $G(BSDXDIE2) N X S X=1/0
    207         ;
    208         N BSDXERR S BSDXERR=$$CHECKICK(.BSDR)
    209         I BSDXERR Q BSDXERR
    210         ;
    211         ; find ien for appt in file 44
    212         NEW IEN,DIE,DA,DR
    213         S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
    214         ;
    215         ; remember before status
    216         ; Failure analysis: Only ^TMP global is set here.
    217         NEW SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL,SDMODE
    218         S DFN=BSDR("PAT"),SDT=BSDR("ADT"),SDCL=BSDR("CLN"),SDMODE=2,SDDA=IEN
    219         S SDCIHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
    220         D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
    221         ;
    222         ; set checkin; Old Code -- keep for ref VEN/SMH 3 Jul 2012
    223         ; S DIE="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
    224         ; S DA(2)=BSDR("CLN"),DA(1)=BSDR("ADT"),DA=IEN
    225         ; S DR="309///"_BSDR("CDT")_";302///`"_BSDR("USR")_";305///"_$$NOW^XLFDT
    226         ; D ^DIE
    227         ;
    228         I $D(BSDXSIMERR3) Q 1_U_"Simulated Error"
    229         ;
    230         ; Failure analysis: If this fails, no other changes were made in this routine
    231         N BSDXIENS S BSDXIENS=IEN_","_BSDR("ADT")_","_BSDR("CLN")_","
    232         N BSDXFDA
    233         S BSDXFDA(44.003,BSDXIENS,309)=BSDR("CDT")
    234         S BSDXFDA(44.003,BSDXIENS,302)=BSDR("USR")
    235         S BSDXFDA(44.003,BSDXIENS,305)=$$NOW^XLFDT()
    236         N BSDXERR
    237         D UPDATE^DIE("","BSDXFDA","BSDXERR")
    238         ;
    239         I $D(BSDXERR) Q 1_U_"Error checking in appointment to file 44. Error: "_BSDXERR("DIERR",1,"TEXT",1)
    240         ;
    241         ; set after status
    242         S SDDA=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
    243         S SDCIHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
    244         D AFTER^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
    245         ;
    246         ; Point of no Return
    247         ; call event driver
    248         D EVT^SDAMEVT(.SDATA,4,SDMODE,SDCIHDL)
    249         Q 0
    250         ;
    251 CHECKIC1(DFN,CLIN,APDATE)       ; Simplified PEP w/ parameters for $$CHECKICK -
    252         ; Check-in Check
    253         ; Call like this for DFN 23435 checking in now at Hospital Location 33
    254         ; for appt at Dec 20, 2009 @ 10:11:59
    255         ; S RESULT=$$CHECKIC1^BSDXAPI(23435,33,3091220.221159)
    256         N BSDR
    257         S BSDR("PAT")=DFN          ;DFN
    258         S BSDR("CLN")=CLIN         ;Hosp Loc IEN
    259         S BSDR("ADT")=APDATE       ;Appt Date
    260         S BSDR("CDT")=$$NOW^XLFDT  ;Check-in date defaults to now
    261         S BSDR("USR")=DUZ          ;Check-in user defaults to current
    262         Q $$CHECKICK(.BSDR)
    263         ;
    264 CHECKICK(BSDR)  ; $$ PEP; - Is it okay to check-in patient?
    265         ; Input: Same as $$CHECKIN
    266         ; Output: 0 if okay or 1^message if error
    267         ;
    268         I $G(BSDXSIMERR2) Q 1_U_"Simulated Error"
    269177        ;
    270178        I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))
     
    277185        ;
    278186        ; find ien for appt in file 44
    279         N IEN S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
     187        NEW IEN,DIE,DA,DR
     188        S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
    280189        I 'IEN Q 1_U_"Error trying to find appointment for checkin: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")
     190        ;
     191        ; remember before status
     192        NEW SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL
     193        S DFN=BSDR("PAT"),SDT=BSDR("ADT"),SDCL=BSDR("CLN"),SDMODE=2,SDDA=IEN
     194        S SDCIHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
     195        D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
     196        ;
     197        ; set checkin
     198        S DIE="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
     199        S DA(2)=BSDR("CLN"),DA(1)=BSDR("ADT"),DA=IEN
     200        S DR="309///"_BSDR("CDT")_";302///`"_BSDR("USR")_";305///"_$$NOW^XLFDT
     201        D ^DIE
     202        ;
     203        ; set after status
     204        S SDDA=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
     205        S SDCIHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
     206        D AFTER^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
     207        ;
     208        ; call event driver
     209        D EVT^SDAMEVT(.SDATA,4,SDMODE,SDCIHDL)
    281210        Q 0
    282211        ;
     
    287216        ; because foxes come out during bad weather.
    288217        ; S RESULT=$$CANCEL1^BSDXAPI(23435,33,"PC",3091220.221159,1,"Afraid of foxes")
    289         N BSDR
    290218        S BSDR("PAT")=DFN
    291219        S BSDR("CLN")=CLIN
     
    316244        ;   = 1^message:  error and reason
    317245        ;
    318         ; Okay to Cancel? Call Cancel Check.
    319         N BSDXCANCK S BSDXCANCK=$$CANCELCK(.BSDR)
    320         I BSDXCANCK Q BSDXCANCK
    321         ;
    322         ; BSDX 1.5 3110125
    323         ; UJO/SMH - Add ability to remove check-in if the patient is checked in
    324         ; VEN/SMH on 3120625/v1.7 - PIMS doesn't care if patient is already checked in
    325         ; Lets you remove appointment anyways! Not like RPMS.
    326         ; Plus... deleting checkin affects S node on 44, which is DELETED anyways!
    327         ;
    328         ; remember before status
    329         NEW SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL,SDMODE
    330         NEW IEN S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
    331         S DFN=BSDR("PAT"),SDT=BSDR("ADT"),SDCL=BSDR("CLN"),SDMODE=2,SDDA=IEN
    332         S SDCPHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
    333         D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL)
    334         ; NB: Here only ^TMP globals are set with before values.
    335         ;
    336         ; get user who made appt and date appt made from ^SC
    337         ;    because data in ^SC will be deleted
    338         ; Appointment Length: ditto
    339         NEW USER,DATE
    340         S USER=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,6)
    341         S DATE=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,7)
    342         N BSDXLEN S BSDXLEN=$$APPLEN(DFN,SDCL,SDT) ; appt length
    343         ;
    344         ; update file 2 info --old code; keep for reference
    345         ;NEW DIE,DA,DR
    346         ;S DIE="^DPT("_DFN_",""S"",",DA(1)=DFN,DA=SDT
    347         ;S DR="3///"_BSDR("TYP")_";14///`"_BSDR("USR")_";15///"_BSDR("CDT")_";16///`"_BSDR("CR")_";19///`"_USER_";20///"_DATE
    348         ;S:$G(BSDR("NOT"))]"" DR=DR_";17///"_$E(BSDR("NOT"),1,160)
    349         ;D ^DIE
    350         N BSDXIENS S BSDXIENS=SDT_","_DFN_","
    351         N BSDXFDA
    352         S BSDXFDA(2.98,BSDXIENS,3)=BSDR("TYP")
    353         S BSDXFDA(2.98,BSDXIENS,14)=BSDR("USR")
    354         S BSDXFDA(2.98,BSDXIENS,15)=BSDR("CDT")
    355         S BSDXFDA(2.98,BSDXIENS,16)=BSDR("CR")
    356         S BSDXFDA(2.98,BSDXIENS,19)=USER
    357         S BSDXFDA(2.98,BSDXIENS,20)=DATE
    358         S:$G(BSDR("NOT"))]"" BSDXFDA(2.98,BSDXIENS,17)=$E(BSDR("NOT"),1,160)
    359         N BSDXERR
    360         D FILE^DIE("","BSDXFDA","BSDXERR")
    361         I $D(BSDXERR) Q 1_U_"Cannot cancel appointment in File 2"
    362         ; Failure point 1: If we fail here, nothing has happened yet.
    363         ;
    364         ; delete data in ^SC -- this does not (typically) fail. Fileman won't stop
    365         NEW DIK,DA
    366         S DIK="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
    367         S DA(2)=BSDR("CLN"),DA(1)=BSDR("ADT"),DA=IEN
    368         D ^DIK
    369         ; Failure point 2: not expected to happen here
    370         ;
    371         ; Update PIMS availability -- this doesn't fail. Global gets/sets only.
    372         D AVUPDTCN^BSDXAPI1(SDCL,SDT,BSDXLEN)
    373         ;
    374         ; call event driver -- point of no return
    375         D CANCEL^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDMODE,SDCPHDL)
    376         ;
    377         Q 0
    378         ;
    379 CANCELCK(BSDR)  ; $$ PEP; Okay to Cancel Appointment?
    380         ; Input: .BSDR array as documented in $$CANCEL
    381         ; Output: 0 or 1^Error message
    382246        I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))
    383247        I '$D(^SC(+$G(BSDR("CLN")),0)) Q 1_U_"Clinic not on file: "_$G(BSDR("CLN"))
     
    390254        I '$D(^SD(409.2,+$G(BSDR("CR")))) Q 1_U_"Cancel Reason error: "_$G(BSDR("CR"))
    391255        ;
    392         NEW IEN S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
     256        NEW IEN,DIE,DA,DR
     257        S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
    393258        I 'IEN Q 1_U_"Error trying to find appointment for cancel: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")
    394259        ;
    395         ; Check-out check. New in v1.7
    396         I $$CO(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"),IEN) Q 1_U_"Cannot delete. Appointment has already been checked-out!"
     260        ; BSDX 1.5 3110125
     261        ; UJO/SMH - Add ability to remove check-in if the patient is checked in
     262        ; I $$CI(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"),IEN) Q 1_U_"Patient already checked in; cannot cancel until checkin deleted: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")
     263        ; Remove check-in if the patient is checked in.
     264        N BSDXRESULT S BSDXRESULT=0 ; Result; should be zero if success; -1 + message if failure
     265        I $$CI(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"),IEN) SET BSDXRESULT=$$RMCI(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
     266        I BSDXRESULT Q BSDXRESULT
     267        ;
     268        ; remember before status
     269        NEW SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL
     270        S DFN=BSDR("PAT"),SDT=BSDR("ADT"),SDCL=BSDR("CLN"),SDMODE=2,SDDA=IEN
     271        S SDCPHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
     272        D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCPHDL)
     273        ;
     274        ; get user who made appt and date appt made from ^SC
     275        ;    because data in ^SC will be deleted
     276        NEW USER,DATE
     277        S USER=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,6)
     278        S DATE=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,7)
     279        ;
     280        ; update file 2 info
     281        NEW DIE,DA,DR
     282        S DIE="^DPT("_DFN_",""S"",",DA(1)=DFN,DA=SDT
     283        S DR="3///"_BSDR("TYP")_";14///`"_BSDR("USR")_";15///"_BSDR("CDT")_";16///`"_BSDR("CR")_";19///`"_USER_";20///"_DATE
     284        S:$G(BSDR("NOT"))]"" DR=DR_";17///"_$E(BSDR("NOT"),1,160)
     285        D ^DIE
     286        ;
     287        ; delete data in ^SC
     288        NEW DIK,DA
     289        S DIK="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
     290        S DA(2)=BSDR("CLN"),DA(1)=BSDR("ADT"),DA=IEN
     291        D ^DIK
     292        ;
     293        ; call event driver
     294        D CANCEL^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDMODE,SDCPHDL)
    397295        Q 0
    398296        ;
     
    404302        Q $S(X:1,1:0)
    405303        ;
     304RMCI(PAT,CLINIC,DATE)    ;PEP; -- Remove Check-in; $$
     305        ; PAT = DFN
     306        ; CLINIC = SC IEN
     307        ; DATE = FM Date/Time of Appointment
     308        ;
     309        ; Returns:
     310        ; 0 if okay
     311        ; -1 if failure
     312        ;
     313        ; Call like this: $$RMCI(233,33,3110102.1130)
     314        ;
     315        ; Move my variables into the ones used by SDAPIs (just a convenience)
     316        NEW SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL
     317        S DFN=PAT,SDT=DATE,SDCL=CLINIC,SDMODE=2,SDDA=$$SCIEN(DFN,SDCL,SDT)
     318        ;
     319        I SDDA<1 QUIT 0    ; Appt cancelled; cancelled appts rm'ed from file 44
     320        ;
     321        ; remember before status
     322        S SDCIHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
     323        D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
     324        ;
     325        ; remove check-in using filer.
     326        N BSDXIENS S BSDXIENS=SDDA_","_DATE_","_CLINIC_","
     327        S BSDXFDA(44.003,BSDXIENS,309)="@"      ; CHECKED-IN
     328        S BSDXFDA(44.003,BSDXIENS,302)="@"      ; CHECK IN USER
     329        S BSDXFDA(44.003,BSDXIENS,305)="@"      ; CHECK IN ENTERED
     330        N BSDXERR
     331        D FILE^DIE("","BSDXFDA","BSDXERR")
     332        I $D(BSDXERR) QUIT "-1~Can't file for Pat "_PAT_" in Clinic "_CLINIC_" at "_DATE_". Fileman reported an error: "_BSDXERR("DIERR",1,"TEXT",1)
     333        ;
     334        ; set after status
     335        S SDDA=$$SCIEN(DFN,SDCL,SDT)
     336        S SDCIHDL=$$HANDLE^SDAMEVT(1),SDATA=SDDA_U_DFN_U_SDT_U_SDCL
     337        D AFTER^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
     338        ;
     339        ; call event driver
     340        D EVT^SDAMEVT(.SDATA,4,SDMODE,SDCIHDL)
     341        QUIT 0
     342        ;
     343SCIEN(PAT,CLINIC,DATE)  ;PEP; returns ien for appt in ^SC
     344        NEW X,IEN
     345        S X=0 F  S X=$O(^SC(CLINIC,"S",DATE,1,X)) Q:'X  Q:$G(IEN)  D
     346        . Q:$P($G(^SC(CLINIC,"S",DATE,1,X,0)),U,9)["C"  ;cancelled
     347         . I +$G(^SC(CLINIC,"S",DATE,1,X,0))=PAT S IEN=X
     348        Q $G(IEN)
     349        ;
     350APPTYP(PAT,DATE)        ;PEP; -- returns type of appt (scheduled or walk-in)
     351        NEW X S X=$P($G(^DPT(PAT,"S",DATE,0)),U,7)
     352        Q $S(X=3:"SCHED",X=4:"WALK-IN",1:"??")
     353        ;
    406354CO(PAT,CLINIC,DATE,SDIEN)       ;PEP; -- returns 1 if appt already checked-out
    407355        NEW X
     
    411359        Q $S(X:1,1:0)
    412360        ;
    413 SCIEN(PAT,CLINIC,DATE)  ;PEP; returns ien for appt in ^SC
    414         NEW X,IEN
    415         S X=0 F  S X=$O(^SC(CLINIC,"S",DATE,1,X)) Q:'X  Q:$G(IEN)  D
    416         . Q:$P($G(^SC(CLINIC,"S",DATE,1,X,0)),U,9)["C"  ;cancelled
    417          . I +$G(^SC(CLINIC,"S",DATE,1,X,0))=PAT S IEN=X
    418         Q $G(IEN)
    419         ;
    420 APPLEN(PAT,CLINIC,DATE) ; $$ PEP; returns an appointment's length
    421         ; Get either the appointment length or zero
    422         N SCIEN S SCIEN=$$SCIEN(PAT,CLINIC,DATE)
    423         Q:SCIEN $P(^SC(CLINIC,"S",DATE,1,SCIEN,0),U,2)
    424         Q 0
    425 APPTYP(PAT,DATE)        ;PEP; -- returns type of appt (scheduled or walk-in)
    426         NEW X S X=$P($G(^DPT(PAT,"S",DATE,0)),U,7)
    427         Q $S(X=3:"SCHED",X=4:"WALK-IN",1:"??")
    428         ;
     361UPDATENOTE(PAT,CLINIC,DATE,NOTE)        ; PEP; Update Note in ^SC for patient's appointment @ DATE
     362        ; PAT = DFN
     363        ; CLINIC = SC IEN
     364        ; DATE = FM Date/Time of Appointment
     365        ;
     366        ; Returns:
     367        ; 0 if okay
     368        ; -1 if failure
     369        N SCIEN S SCIEN=$$SCIEN(PAT,CLINIC,DATE) ; ien of appt in ^SC
     370        I SCIEN<1 QUIT 0    ; Appt cancelled; cancelled appts rm'ed from file 44
     371        N BSDXIENS S BSDXIENS=SCIEN_","_DATE_","_CLINIC_","
     372        S BSDXFDA(44.003,BSDXIENS,3)=$E(NOTE,1,150)
     373        N BSDXERR
     374        D FILE^DIE("","BSDXFDA","BSDXERR")
     375        I $D(BSDXERR) QUIT "-1~Can't file for Pat "_PAT_" in Clinic "_CLINIC_" at "_DATE_". Fileman reported an error: "_BSDXERR("DIERR",1,"TEXT",1)
     376        QUIT 0
  • Scheduling/trunk/m/BSDXAPI1.m

    r1481 r1563  
    11BSDXAPI1        ; VEN/SMH - SCHEDULING APIs - Continued!!! ; 7/9/12 2:22pm
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.7;BSDX;;Oct 04, 2012;Build 25
    33        ; Licensed under LGPL 
    44        ;
  • Scheduling/trunk/m/BSDXGPRV.m

    r1481 r1563  
    1 BSDXGPRV        ; WV/SMH - WINDOWS SCHEDULING RPCS ; 7/6/12 11:07am
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     1BSDXGPRV        ; WV/SMH - WINDOWS SCHEDULING RPCS ; 4/28/11 10:31am
     2        ;;1.6;BSDX;;Aug 31, 2011;Build 25
    33        ; Licensed under LGPL 
    44        ;
     
    1818PD(BSDXY,HLIEN) ;EP Debugging entry point
    1919        ;
    20         ;D DEBUG^%Serenji("P^BSDXGPRV(.BSDXY,HLIEN)","192.168.254.130")
     20        D DEBUG^%Serenji("P^BSDXGPRV(.BSDXY,HLIEN)","192.168.254.130")
    2121        ;
    2222        Q
     
    3333        S BSDXI=0
    3434        I '$D(^SC(HLIEN,0)) D ERR("HOSPITAL LOCATION NOT FOUND") QUIT
    35         D ^XBKVAR
     35        D ^XBKVAR 
    3636        N $ET S $ET="G ERROR^BSDXGPRV"
    3737        K ^BSDXTMP($J)
  • Scheduling/trunk/m/BSDXUT.m

    r1481 r1563  
    11BSDXUT  ; VEN/SMH - Unit Tests for Scheduling GUI ; 6/29/12 12:20pm
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.7;BSDX;;Oct 04, 2012;Build 25
    33        ; Licensed under LGPL
    44        ;
  • Scheduling/trunk/m/BSDXUT1.m

    r1481 r1563  
    11BSDXUT1 ; VEN/SMH - Unit Tests for Scheduling GUI - cont. ; 7/9/12 12:31pm
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.7;BSDX;;Oct 04, 2012;Build 25
    33        ;
    44        ;
  • Scheduling/trunk/m/BSDXUT2.m

    r1481 r1563  
    11BSDXUT2 ; VEN/SMH - Unit Tests for Scheduling GUI - cont. ; 7/9/12 3:18pm
    2         ;;1.7T2;BSDX;;Jul 11, 2012;Build 18
     2        ;;1.7;BSDX;;Oct 04, 2012;Build 25
    33        ;
    44EN      ; Run all unit tests in this routine
Note: See TracChangeset for help on using the changeset viewer.