Changeset 1625 for Scheduling


Ignore:
Timestamp:
Jun 1, 2013, 10:54:38 AM (11 years ago)
Author:
Tariq Hamkari
Message:

Ayman Ghaith : adding the correct routines which not has the transactions.

Location:
Scheduling/trunk/m
Files:
41 edited

Legend:

Unmodified
Added
Removed

  • Scheduling/trunk/m/BSDX01.m

    r1563 r1625  
    1 BSDX01  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 5/16/11 2:46pm
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     1BSDX01  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 1/29/13 12:53pm
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 2
    33        ; Licensed under LGPL
    44        ;
    … …  
    77        ;
    88        Q
    9         ;
    10 SUINFO(BSDXY,BSDXDUZ)    ;EP
     9        ;EHS/WAT;UJOK*1.0*4 ;JAN 24,2013;Update [Updating the SUINFO function by adding a new parameter "USERKEY" that holds the name of the user key].
     10           ;EHS/WAT;UJO*2.0*31 ;JAN 24,2013;Update [Updating the SUINFO function by adding a new parameter "USERKEY" that holds the name of the user key].
     11           ;SUINFO(BSDXY,BSDXDUZ)    ;EP
     12SUINFO(BSDXY,BSDXDUZ,USERKEY)    ;EP
    1113        ;Called by BSDX SCHEDULING USER INFO
    1214        ;Returns ADO Recordset having column MANAGER
    … …  
    2123        ;Check SECURITY KEY file for BSDXZMGR or XUPROGMODE keys
    2224        I '+BSDXDUZ S BSDXDUZ=DUZ
    23         S BSDXMGR=$$APSEC("BSDXZMGR",BSDXDUZ)
     25        ;EHS/WAT;UJOK*1.0*4 ;JAN 24,2013; Update [Updating the argument sent to $$APSEC function from hard coded string "BSDXZMGR" to "USERKEY" variable].
     26           ;EHS/WAT;UJO*2.0*31 ;JAN 24,2013; Update [Updating the argument sent to $$APSEC function from hard coded string "BSDXZMGR" to "USERKEY" variable].
     27           ;S BSDXMGR=$$APSEC("BSDXZMGR",BSDXDUZ);
     28           S BSDXMGR=$$APSEC(USERKEY,BSDXDUZ)
    2429        S BSDXMGR=$S(BSDXMGR=1:"YES",1:"NO")
    2530        S BSDXI=BSDXI+1
    2631        S ^BSDXTMP($J,BSDXI)=BSDXMGR_$C(30)
    27         S ^BSDXTMP($J,BSDXI+1)=$C(31)_BSDXERR
     32        S ^BSDXTMP($J,BSDXI+1)=$C(31)_BSDXERR   
    2833        Q
    2934DEPUSRD(BSDXY,BSDXDUZ)  ;EP Debugging entry point
    … …  
    282287        ;
    283288INDIV(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
    294            QUIT
     289        ; Input: BSDXSC - Hospital Location IEN
     290        ; Output: True or False
     291        I '+BSDXSC QUIT 1  ;If not tied to clinic, yes
     292        I '$D(^SC(BSDXSC,0)) QUIT 1 ; If Clinic does not exist, yes
     293        ; Jump to Division:Medical Center Division:Inst File Pointer for
     294        ; Institution IEN (and get its internal value)
     295        N DIV S DIV=$$GET1^DIQ(44,BSDXSC_",","3.5:.07","I")
     296        I DIV="" Q 1 ; If clinic has no division, consider it avial to user.
     297        I DIV=DUZ(2) Q 1 ; If same, then User is in same Div as Clinic
     298        E  Q 0 ; Otherwise, no
    295299INDIV2(BSDXRES) ; PEP - Is Resource in the same DUZ(2) as user?
    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
    299 UnitTestINDIV   
    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
    313 UnitTestINDIV2 
    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            ;
     300        ; Input BSDXRES - BSDX RESOURCE IEN
     301        ; Output: True of False
     302        Q $$INDIV($P($G(^BSDXRES(BSDXRES,0)),U,4)) ; Extract Hospital Location and send to $$INDIV
     303UTINDIV ; Unit Test $$INDIV
     304        W "Testing if they are the same",!
     305        S DUZ(2)=67
     306        I '$$INDIV(1) W "ERROR",!
     307        I '$$INDIV(2) W "ERROR",!
     308        W "Testing if Div not defined in 44, should be true",!
     309        I '$$INDIV(3) W "ERROR",!
     310        W "Testing empty string. Should be true",!
     311        I '$$INDIV("") W "ERROR",!
     312        W "Testing if they are different",!
     313        S DUZ(2)=899
     314        I $$INDIV(1) W "ERROR",!
     315        I $$INDIV(2) W "ERROR",!
     316        QUIT
     317UTINDIV2        ; Unit Test $$INDIV2
     318        W "Testing if they are the same",!
     319        S DUZ(2)=69
     320        I $$INDIV2(22)'=0 W "ERROR",!
     321        I $$INDIV2(25)'=1 W "ERROR",!
     322        I $$INDIV2(26)'=1 W "ERROR",!
     323        I $$INDIV2(27)'=1 W "ERROR",!
     324        QUIT
     325        ;
    322326GETRADEX(BSDXY,DFN,SCIEN)       ; Get All Pending and On Hold Radiology Exams for Patient; RPC EP; UJO/SMH new in v 1.6
    323327        ; RPC: BSDX GET RAD EXAM FOR PT; Return: Global Array
    … …  
    346350        ; Fields 5 = Request Status; 2 = Procedure; 16 = Requested Entered Date Time
    347351        ; Filter Field: First piece is DFN, 5th piece is 3 or 5 (Status of Pending Or Hold); 20th piece is Radiology Location requested
    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]
     352               ;;EHS/MKH,BAH;;BSDX 1.7;;30/09/2012;; Update [Fix the performance issue in SchedGUI]
     353               ; START OF CODE CHANGES FOR [BSDX 1.7]
    351354               ; 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")
     355               ;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","BSDXE>>RR")
    353356               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]
     357               ; END OF CODE CHANGES FOR [BSDX 1.7]
    355358        ;
    356359        IF $DATA(BSDXERR) GOTO END

  • Scheduling/trunk/m/BSDX02.m

    r1563 r1625  
    1 BSDX02  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 5/16/11 2:47pm
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     1BSDX02  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/6/12 11:09am
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    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^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"
     33        S ^(0)=^(0)_"^I00005NOSHOW^T00020HRN^I00005ACCESSTYPEID^I00005WALKIN^T00250NOTE^T00006SEX^T00040PID^D00030DOB^I00020RADIOLOGY_EXAM"_$C(30)
    3334        D ^XBKVAR S X="ETRAP^BSDX02",@^%ZOSF("TRAP")
    3435        ;
    … …  
    3738        ; S %DT="T",X=BSDXEND D ^%DT S BSDXEND=Y
    3839        ; I BSDXEND=-1 S ^BSDXTMP($J,1)=$C(31) Q
    39            ;
     40        ;
    4041        S BSDXI=0
    4142        D STRES

  • Scheduling/trunk/m/BSDX03.m

    r1563 r1625  
    11BSDX03  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:14am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ;Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX04.m

    r1563 r1625  
    1 BSDX04  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;  ; 4/28/11 10:15am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     1BSDX04  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;  ; 7/6/12 10:55am
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    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

    r1563 r1625  
    11BSDX05   ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:16am
    2            ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2           ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33           ; Licensed under LGPL
    44           ;

  • Scheduling/trunk/m/BSDX06.m

    r1563 r1625  
    11BSDX06  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:16am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ; Change Log:

  • Scheduling/trunk/m/BSDX07.m

    r1563 r1625  
    1 BSDX07  ; 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        
     1BSDX07  ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS  ; 7/9/12 4:02pm
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
     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        ;
    2829APPADDD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)       ;EP
    29            ;Entry point for debugging
    30            D DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)")
    31            Q
    32            ;
    33 UT      ; 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            ;
    82 APPADD(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
    213 BSDXDEL(BSDXAPPTID)     ;Deletes appointment BSDXAPPTID from BSDXAPPOINTMETN
    214            N DA,DIK
    215            S DIK="^BSDXAPPT(",DA=BSDXAPPTID
    216            D ^DIK
    217            Q
    218            ;
     30        ;Entry point for debugging
     31        ; D DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)")
     32        Q
     33        ;
     34APPADD(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
    219178STRIP(BSDXZ)       ;Replace control characters with spaces
    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            ;
     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        ;
    224183BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM)       ;ADD BSDX APPOINTMENT ENTRY
    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            ;
     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        ;
    242201BSDXWP(BSDXAPPTID,BSDXNOTE)     ;
    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            ;
     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        ;
    250210ADDEVT(BSDXPATID,BSDXSTART,BSDXSC,BSDXSCDA)     ;EP
    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            ;
     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        ;
    275235ADDEVT3(BSDXRES)           ;
    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            ;
    285 ERR(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            ;
     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        ;
     245ROLLBACK(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        ;
     255BSDXDEL(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        ;
     262ERR(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        ;
    295274ETRAP     ;EP Error trap entry
    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            ;
    306 DAY     ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
    307            ;
    308 DOW     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            ;
    313 AVUPDT(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
    325 1         ;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
    330 EN1     S (X,SD)=Y,SM=0 D DOW
    331 S         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)
    341 SC       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            ;
    348 SP       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
     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        ;

  • Scheduling/trunk/m/BSDX08.m

    r1563 r1625  
    1 BSDX08  ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 4/28/11 10:17am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     1BSDX08  ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 7/9/12 4:22pm
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ;
    44        ; Original by HMW. New Written by Sam Habiel. Licensed under LGPL.
    … …  
    66        ; Change History
    77        ; 3101022 UJO/SMH v1.42
    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.
     8        ;  - Transaction work. As of v 1.7, all work here has been superceded
     9        ;  - Refactoring of AVUPDT - never tested though.
    1610        ;  - Refactored all of APPDEL.
    1711        ;
    … …  
    1913        ;  - Added ability to remove checked in appointments. Added a couple
    2014        ;    of units tests for that under UT2.
    21         ;  - Minor reformatting because of how KIDS adds tabs.
     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.
    2220        ;
    2321        ; Error Reference:
    … …  
    3129        ;  -8^BSDX08: Unable to find associated PIMS appointment for this patient
    3230        ;  -9^BSDX08: BSDXAPI returned an error: (error)
     31        ;  -10^BSDX08: $$BSDXCAN failed (Fileman filing error)
    3332        ;  -100~BSDX08 Error: (Mumps Error)
    3433        ;
    3534APPDELD(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT) ;EP
    3635        ;Entry point for debugging
    37         D DEBUG^%Serenji("APPDEL^BSDX08(.BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)")
    38         Q
    39         ;
    40 UT      ; 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",!
    79 UT2     ; 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
    102 APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)         ;EP
     36        ;D DEBUG^%Serenji("APPDEL^BSDX08(.BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)")
     37        Q
     38        ;
     39APPDEL(BSDXY,BSDXAPTID,BSDXTYP,BSDXCR,BSDXNOT)         ; Private EP
    10340        ;Called by RPC: BSDX CANCEL APPOINTMENT
    10441        ;Cancels existing appointment in BSDX APPOINTMENT and 44/2 subfiles
    … …  
    12461        ; Counter
    12562        N BSDXI S BSDXI=0
     63        ;
    12664        ; Header Node
    12765        S ^BSDXTMP($J,BSDXI)="T00100ERRORID"_$C(30)
    12866        ;
     67        ; Turn off SDAM APPT PROTOCOL BSDX Entries
     68        N BSDXNOEV
     69        S BSDXNOEV=1 ;Don't execute BSDX CANCEL APPOINTMENT protocol
     70        ;
     71        ;;;test for error inside transaction. See if %ZTER works
     72        I $G(BSDXDIE1) N X S X=1/0
     73        ;
     74        ; Check appointment ID and whether it exists
     75        I '+BSDXAPTID D ERR(BSDXI,"-2~BSDX08: Invalid Appointment ID") Q
     76        I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"-3~BSDX08: Invalid Appointment ID") Q
     77        ;
    12978        ; Lock BSDX node, only to synchronize access to the globals.
    13079        ; It's not expected that the error will ever happen as no filing
    13180        ; 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"
    137         ;
    138         ; Turn off SDAM APPT PROTOCOL BSDX Entries
    139         N BSDXNOEV
    140         S BSDXNOEV=1 ;Don't execute BSDX CANCEL APPOINTMENT protocol
    141         ;
    142         ;;;test for error inside transaction. See if %ZTER works
    143         I $G(bsdxdie) S X=1/0
    144         ;;;test
    145         ;;;test for TRESTART
    146         I $G(bsdxrestart) K bsdxrestart TRESTART
    147         ;;;test
    148         ;
    149         ; Check appointment ID and whether it exists
    150         I '+BSDXAPTID D ERR(BSDXI,"-2~BSDX08: Invalid Appointment ID") Q
    151         I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR(BSDXI,"-3~BSDX08: Invalid Appointment ID") Q
     81        L +^BSDXAPPT(BSDXAPTID):5 E  D ERR(BSDXI,"-1~BSDX08: Appt record is locked. Please contact technical support.") Q
    15282        ;
    15383        ; Start Processing:
    154         ; First, add cancellation date to appt entry in BSDX APPOINTMENT
     84        ; First, get data
    15585        N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPTID,0) ; BSDX Appt Node
    15686        N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; Patient ID
    15787        N BSDXSTART S BSDXSTART=$P(BSDXNOD,U) ; Start Time
    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
     88        ;
     89        ; Check the resource ID and whether it exists
    16190        N BSDXSC1 S BSDXSC1=$P(BSDXNOD,U,7) ;RESOURCEID
    162         ; If the resouce id doesn't exist...
     91        ; If the resource id doesn't exist...
    16392        I BSDXSC1="" D ERR(BSDXI,"-4~BSDX08: Cancelled appointment does not have a Resouce ID") QUIT
    16493        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
    16597        ; Get zero node of resouce
    166         S BSDXNOD=^BSDXRES(BSDXSC1,0)
     98        N BSDXNOD S BSDXNOD=^BSDXRES(BSDXSC1,0)
    16799        ; Get Hosp location
    168100        N BSDXLOC S BSDXLOC=$P(BSDXNOD,U,4)
    169         ; Error indicator for Hosp Location filing for getting out of routine
     101        ; Error indicator
    170102        N BSDXERR S BSDXERR=0
    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
     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        ;
    190135        L -^BSDXAPPT(BSDXAPTID)
    191136        S BSDXI=BSDXI+1
    … …  
    195140        Q
    196141        ;
    197 AVUPDT(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         ;
    243 APCAN(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         ;
    261 BSDXCAN(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
     142BSDXCAN(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()
    266147        S BSDXIENS=BSDXAPTID_","
    267148        S BSDXFDA(9002018.4,BSDXIENS,.12)=BSDXDATE
    268         K BSDXMSG
    269149        D FILE^DIE("","BSDXFDA","BSDXMSG")
    270         Q
     150        I $D(BSDXMSG) Q 1_U_BSDXMSG("DIERR",1,"TEXT",1)
     151        QUIT 0
     152        ;
     153ROLLBACK(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
    271161        ;
    272162CANEVT(BSDXPAT,BSDXSTART,BSDXSC)        ;EP Called by BSDX CANCEL APPOINTMENT event
    … …  
    292182        Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND
    293183        S BSDXAPPT=0 F  S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT  D  Q:BSDXFOUND
     184        . N BSDXNOD
    294185        . S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
    295186        . I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q
    296         I BSDXFOUND,+$G(BSDXAPPT) D BSDXCAN(BSDXAPPT)
     187        I BSDXFOUND,+$G(BSDXAPPT) N % S %=$$BSDXCAN(BSDXAPPT) I % D ^%ZTER
    297188        Q BSDXFOUND
    298189        ;
    … …  
    309200        ;
    310201ERR(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
    311206        S BSDXI=BSDXI+1
    312207        S BSDXERR=$TR(BSDXERR,"^","~")
    313         I $TL>0 TROLLBACK
    314208        S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
    315209        S BSDXI=BSDXI+1
    316210        S ^BSDXTMP($J,BSDXI)=$C(31)
    317         L -^BSDXAPPT(BSDXAPTID)
    318211        QUIT
    319212        ;
    320213ETRAP   ;EP Error trap entry
    321214        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
    324215        D ^%ZTER
    325         S $EC=""  ; Clear Error
     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        ;
    326222        ; Log error message and send to client
    327223        I '$D(BSDXI) N BSDXI S BSDXI=0
    328224        D ERR(BSDXI,"-100~BSDX08 Error: "_$G(%ZTERZE))
    329         QUIT
     225        Q:$Q 1_U_"-100~Mumps Error" Q
    330226        ;
    331227        ;;;NB: This is code that is unused in both original and port.

  • Scheduling/trunk/m/BSDX09.m

    r1563 r1625  
    1 BSDX09  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;  ; 4/28/11 10:18am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     1BSDX09  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;  ; 6/21/12 11:03am
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX11.m

    r1563 r1625  
    11BSDX11  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:18am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX12.m

    r1563 r1625  
    11BSDX12  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:18am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX13.m

    r1563 r1625  
    11BSDX13  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:19am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX14.m

    r1563 r1625  
    11BSDX14  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:19am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX15.m

    r1563 r1625  
    11BSDX15  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:19am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX16.m

    r1563 r1625  
    11BSDX16  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ;  ; 4/28/11 10:20am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX17.m

    r1563 r1625  
    11BSDX17  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:20am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX18.m

    r1563 r1625  
    11BSDX18  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:20am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX19.m

    r1563 r1625  
    11BSDX19  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:21am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX20.m

    r1563 r1625  
    11BSDX20  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:21am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX21.m

    r1563 r1625  
    11BSDX21  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:22am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX22.m

    r1563 r1625  
    11BSDX22  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:22am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX23.m

    r1563 r1625  
    11BSDX23  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:22am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX24.m

    r1563 r1625  
    11BSDX24  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:22am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX25.m

    r1563 r1625  
    1 BSDX25  ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 4/28/11 10:24am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     1BSDX25  ; VEN/SMH - WINDOWS SCHEDULING RPCS ; 7/9/12 5:00pm
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;
    55        ; Change Log:
    66        ; 3110106: SMH -> Changed Check-in EP - Removed unused paramters. Will change C#
    7         ;
    8         ;
    9 UT      ; 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
    42 CHECKIND(BSDXY,BSDXAPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG) ;EP
     7        ; 3120630: VEN/SMH -> Extensive Refactoring to remove transactions.
     8        ;                  -> Functionality still the same.
     9        ;                  -> Unit Tests in UT25^BSDXUT2
     10        ;
     11        ;
     12CHECKIND(BSDXY,BSDXAPPTID,BSDXCDT,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG)        ;EP
    4313        ;Entry point for debugging
    4414        ;
    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         ;
    48 CHECKIN(BSDXY,BSDXAPTID,BSDXCDT)        ; ,BSDXCC,BSDXPRV,BSDXROU,BSDXVCL,BSDXVFM,BSDXOG)       ;EP Check in appointment
     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        ;
     18CHECKIN(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        ;
    4922        ; Private to GUI; use BSDXAPI for general API to checkin patients
    5023        ; Parameters:
    5124        ; BSDXY: Global Out
    52         ; BSDXAPTID: Appointment ID in ^BSDXAPPT
     25        ; BSDXAPPTID: Appointment ID in ^BSDXAPPT
    5326        ; BSDXCDT: Checkin Date --> Changed
    5427        ; BSDXCC: Clinic Stop IEN (not used)
    … …  
    5730        ; BSDXVCL: PCC+ Clinic IEN (not used)
    5831        ; BSDXVFM: PCC+ Form IEN (not used)
    59         ; BSDXOG: PCC+ Outguide (true or false)
     32        ; BSDXOG: PCC+ Outguide (true or false) (not used)
    6033        ;
    6134        ; Output:
    … …  
    6336        ; - 0 if all okay
    6437        ; - Another number or text if not
    65        
    66         N BSDXNOD,BSDXPATID,BSDXSTART,DIK,DA,BSDXID,BSDXI,BSDXZ,BSDXIENS,BSDXVEN
     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
    6748        N BSDXNOEV
    6849        S BSDXNOEV=1 ;Don't execute protocol
    6950        ;
    70         D ^XBKVAR S X="ERROR^BSDX25",@^%ZOSF("TRAP")
    71         S BSDXI=0
    72         K ^BSDXTMP($J)
    73         S BSDXY="^BSDXTMP("_$J_")"
     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        ;
    7465        S ^BSDXTMP($J,0)="T00020ERRORID"_$C(30)
    75         I '+BSDXAPTID D ERR("BSDX25: Invalid Appointment ID") Q
    76         I '$D(^BSDXAPPT(BSDXAPTID,0)) D ERR("BSDX08: Invalid Appointment ID") Q
     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        ;
    7775        ; Remove Date formatting v.1.5. Client will send date as FM Date.
    7876        ;S:BSDXCDT["@0000" BSDXCDT=$P(BSDXCDT,"@")
    7977        ;S %DT="T",X=BSDXCDT D ^%DT S BSDXCDT=Y
    80            S BSDXCDT=+BSDXCDT  ; Strip off zeros if C# sends them
    81         I BSDXCDT=-1 D ERR(70) Q
     78        S BSDXCDT=+BSDXCDT  ; Strip off zeros if C# sends them
     79        I BSDXCDT'>2000000 D ERR("-2~Invalid Check-in Date") QUIT
    8280        I BSDXCDT>$$NOW^XLFDT S BSDXCDT=$$NOW^XLFDT
    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         ;
     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)
    95110        S BSDXI=BSDXI+1
    96111        S ^BSDXTMP($J,BSDXI)="0"_$C(30)
    … …  
    99114        Q
    100115        ;
    101 BSDXCHK(BSDXAPTID,BSDXCDT)      ;
    102         ;
    103         S BSDXIENS=BSDXAPTID_","
     116BSDXCHK(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_","
    104128        S BSDXFDA(9002018.4,BSDXIENS,.03)=BSDXCDT
    105129        D FILE^DIE("","BSDXFDA","BSDXMSG")
    106         Q
    107         ;
    108 APCHK(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         ;
    114 RMCI(BSDXY,BSDXAPPTID)  ; EP - Remove Check-in from BSDX APPT and 2/44
    115         ; Called by RPC [Fill in later]
     130        Q:$D(BSDXMSG) 1_U_BSDXMSG("DIERR",1,"TEXT",1)
     131        Q 0
     132        ;
     133RMCI(BSDXY,BSDXAPPTID)  ; Private EP - Remove Check-in from BSDX APPT and 2/44
     134        ; Called by RPC BSDX REMOVE CHECK-IN
    116135        ;
    117136        ; Parameters to pass:
    … …  
    128147        ; -4~DB has corruption. Call Tech Support. (Resource ID in BSDXAPPT doesnt exist in BSDXRES)
    129148        ; -5~BSDXAPI Error. Message depends on error.
    130         ; -20~Mumps Error
     149        ; -6~Data Filing Error in BSDXCHK
     150        ; -7~Lock not acquired
     151        ; -100~Mumps Error
    131152        ;
    132153        N BSDXNOEV S BSDXNOEV=1 ;Don't execute protocol
    … …  
    142163        S ^BSDXTMP($J,BSDXI)="T00020ERRORID"_$C(30) ; Header of ADO recordset
    143164        ;
    144         TSTART (BSDXI):SERIAL ; Perform Autolocking
    145         ;
    146165        ;;;test
    147         I $g(bsdxdie) S X=8/0
    148         ;;;
    149         I $g(bsdxrestart) k bsdxrestart TRESTART
    150         ;;;test
     166        I $G(BSDXDIE) N X S X=8/0
    151167        ;
    152168        ; Check for Appointment ID (passed and exists in file)
    … …  
    154170        I '$D(^BSDXAPPT(BSDXAPPTID,0)) D ERR("-2~Invalid Appointment ID") QUIT
    155171        ;
     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
     177        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
     181        ;
     182        ; 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        ;
    156200        ; Remove checkin from BSDX APPOINTMENT entry
    157         D BSDXCHK(BSDXAPPTID,"@")
     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
    158204        ;
    159205        ; Now, remove checkin from PIMS files 2/44
    160         N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPPTID,0)
    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
    164         ;
    165         ; If the resource doesn't exist, error out. DB is corrupt.
    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
     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)
    177215        ;
    178216        ; Return ADO recordset
    … …  
    208246        Q:'$D(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART)) BSDXFOUND
    209247        S BSDXAPPT=0 F  S BSDXAPPT=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXSTART,BSDXAPPT)) Q:'+BSDXAPPT  D  Q:BSDXFOUND
    210         . S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
     248        . N BSDXNOD S BSDXNOD=$G(^BSDXAPPT(BSDXAPPT,0)) Q:BSDXNOD=""
    211249        . I $P(BSDXNOD,U,5)=BSDXPAT,$P(BSDXNOD,U,12)="" S BSDXFOUND=1 Q
    212         I BSDXFOUND,+$G(BSDXAPPT) D BSDXCHK(BSDXAPPT,BSDXSTAT)
     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
    213253        Q BSDXFOUND
    214254        ;
    … …  
    225265ERROR   ;
    226266        S $ETRAP="D ^%ZTER HALT"  ; Emergency Error Trap for the wise
    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
     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
    234278        ;
    235279ERR(BSDXERR)    ;Error processing
    236         I $TLEVEL>0 TROLLBACK
     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
    237284        S BSDXERR=$G(BSDXERR)
    238285        S BSDXERR=$P(BSDXERR,"~")_"~"_$TEXT(+0)_":"_$P(BSDXERR,"~",2) ; Append Routine Name

  • Scheduling/trunk/m/BSDX26.m

    r1563 r1625  
    1 BSDX26   ; 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            ;
     1BSDX26   ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/10/12 10:27am
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
     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        ;
    1420EDITAPTD(BSDXY,BSDXAPTID,BSDXNOTE)       ;EP
    15            ;Entry point for debugging
    16            ;
    17            D DEBUG^%Serenji("EDITAPT^BSDX26(.BSDXY,BSDXAPTID,BSDXNOTE)")
    18            Q
    19 UT      ; 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            ;
     21        ;Entry point for debugging
     22        ;
     23        ;D DEBUG^%Serenji("EDITAPT^BSDX26(.BSDXY,BSDXAPTID,BSDXNOTE)")
     24        Q
    5425EDITAPT(BSDXY,BSDXAPTID,BSDXNOTE)         ;EP Edit appointment (only note text can be edited)
    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            ;
     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        ;
     101ROLLBACK(BSDXAPTID)     ; Rollback note to original in ^BSDXAPPT
     102        M ^BSDXAPPT(BSDXAPTID)=^TMP($J,"BEFORE","BSDXAPPT")
     103        K ^TMP($J)
     104        QUIT
     105        ;
    117106ERR(BSDXI,BSDXERR)       ;Error processing
    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            ;
     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        ;
    126118ETRAP     ;EP Error trap entry
    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
     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

  • Scheduling/trunk/m/BSDX27.m

    r1563 r1625  
    11BSDX27   ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:24am
    2            ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2           ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33           ; Licensed under LGPL
    44           ;

  • Scheduling/trunk/m/BSDX28.m

    r1563 r1625  
    1 BSDX28  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:25am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     1BSDX28  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/6/12 10:57am
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    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   
    79            ;Chart# Lookup
     78CHART   ;Chart# Lookup
    8079        I +DUZ(2),BSDXP]"",$D(^AUPNPAT("D",BSDXP)) D  S BSDXY=BSDXRET_$C(31) Q
    8180        . 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

    r1563 r1625  
    1 BSDX29  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:25am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     1BSDX29  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/9/12 11:50am
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    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.
    1110        ; - 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
    1214        ;
    1315BSDXCPD(BSDXY,BSDXRES,BSDX44,BSDXBEG,BSDXEND)   ;EP
    1416        ;Entry point for debugging
    1517        ;
    16         D DEBUG^%Serenji("BSDXCP^BSDX29(.BSDXY,BSDXRES,BSDX44,BSDXBEG,BSDXEND)")
     18        ;D DEBUG^%Serenji("BSDXCP^BSDX29(.BSDXY,BSDXRES,BSDX44,BSDXBEG,BSDXEND)")
    1719        Q
    1820        ;
    … …  
    2224           ;Called by RPC: BSDX COPY APPOINTMENTS
    2325        ;
    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            ;
     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        ;
    3133        ;Returns ADO Recordset containing TASK_NUMBER and ERRORID
    3234        ;
    33            ; Return Array
     35        ; Return Array
    3436        S BSDXY=$NA(^BSDXTMP($J))
    35            K ^BSDXTMP($J)
    36            ; $ET
    37            N $ET S $ET="G ETRAP^BSDX29"
     37        K ^BSDXTMP($J)
     38        ; $ET
     39        N $ET S $ET="G ETRAP^BSDX29"
    3840        ; Counter
    39            N BSDXI S BSDXI=0
    40            ; Header Node
     41        N BSDXI S BSDXI=0
     42        ; Header Node
    4143        S ^BSDXTMP($J,0)="T00010TASK_NUMBER^T00100ERRORID"_$C(30)
    4244        ;
    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
     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
    4951        ; Task Load
    50         S ZTRTN="ZTM^BSDX29",ZTDTH=$H,ZTDESC="COPY PATIENT APPTS"
     52        S ZTRTN="ZTM^BSDX29",ZTDTH=$H,ZTDESC="COPY PATIENT APPTS",ZTIO=""
    5153        S ZTSAVE("BSDXBEG")="",ZTSAVE("BSDXEND")="",ZTSAVE("BSDX44")="",ZTSAVE("BSDXRES")=""
    5254        D ^%ZTLOAD
    … …  
    6264        ;
    6365ZTM     ;EP - Taskman entry point
    64            ; Variables set up in ZTSAVE above
    65            ;
     66        ; Variables set up in ZTSAVE above
     67        ;
    6668        Q:'$D(ZTSK)
    67            ; $ET
    68            N $ET S $ET="G ZTMERR^BSDX29"
    69         ; Txn
    70            TSTART (BSDXBEG,BSDXEND,BSDX44,BSDXRES):T="BSDX COPY APPOINTMENT^BSDX29"
     69        ;
     70        ; $ET
     71        N $ET S $ET="G ZTMERR^BSDX29"
     72        ;
    7173        ;$O through ^SC(BSDX44,"S",
    7274        N BSDXCNT S BSDXCNT=0  ; Count of Copied Appointments
    73            N BSDXQUIT S BSDXQUIT=0  ; Quit Flag to be retrieved from an external proc
     75        N BSDXQUIT S BSDXQUIT=0  ; Quit Flag to be retrieved from an external proc
    7476        ; Set Count
    75            S ^BSDXTMP("BSDXCOPY",ZTSK)=BSDXCNT
     77        S ^BSDXTMP("BSDXCOPY",ZTSK)=BSDXCNT
    7678        ; Loop through dates here.
    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
     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
    8183        . F  S BSDXIEN=$O(^SC(BSDX44,"S",BSDXBEG,1,BSDXIEN)) Q:'+BSDXIEN  Q:BSDXQUIT  D
    8284        . . N BSDXNOD S BSDXNOD=$G(^SC(BSDX44,"S",BSDXBEG,1,BSDXIEN,0)) ; Node
    8385        . . Q:'+BSDXNOD  ; Quit if no node
    8486        . . N BSDXCAN S BSDXCAN=$P(BSDXNOD,U,9) ; Cancel flag
    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
     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
    8890        . . N BSDXCLRK S BSDXCLRK=$P(BSDXNOD,U,6) ;appt made by (clerk)
    8991        . . N BSDXMADE S BSDXMADE=$P(BSDXNOD,U,7) ;date appt made
    … …  
    9193        . . S BSDXCNT=BSDXCNT+$$XFER(BSDXRES,BSDXBEG,BSDXPAT,BSDXLEN,BSDXCLRK,BSDXMADE,BSDXNOTE)
    9294        . . I +BSDXCNT,BSDXCNT#10=0 S ^BSDXTMP("BSDXCOPY",ZTSK)=BSDXCNT_" records copied." ;every 10th record
    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
     95        . . I $D(^BSDXTMP("BSDXCOPY",ZTSK,"CANCEL")) S BSDXQUIT=1 ;Check for cancel flag ; smh - not used currently (v1.7)
     96        ;
     97        ;
    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
    105103        D ^%ZTER
    106            S $EC="" ; Clear Error
    107104        QUIT
    108105        ;
    … …  
    112109        ;Return 1 if record copied, otherwise 0
    113110        ;
     111        N REF
     112        S REF=$NA(^BSDXLOCK(BSDXRES,BSDXBEG,BSDXPAT)) ; This combo is unique
     113        L +@REF:0  E  Q 0
     114        ;
    114115        ;$O Thru ^BSDXAPPT to determine if this appt already added
    115         N BSDXEND,BSDXIEN,BSDXFND,BSDXPAT2
     116        N BSDXEND,BSDXIEN,BSDXFND,BSDXPAT2,BSDXNOD
    116117        S BSDXIEN=0,BSDXFND=0
    117118        F  S BSDXIEN=$O(^BSDXAPPT("ARSRC",BSDXRES,BSDXBEG,BSDXIEN)) Q:'+BSDXIEN  D  Q:BSDXFND
    … …  
    122123        . I BSDXPAT2=BSDXPAT S BSDXFND=1
    123124        . Q
    124         Q:BSDXFND 0
     125        I BSDXFND L -@REF Q 0
    125126        ;
    126127        ;Add to BSDX APPOINTMENT
    … …  
    128129        ;Calculate ending time from beginning time and duration.
    129130        S BSDXEND=$$ADDMIN(BSDXBEG,BSDXLEN)
     131        N BSDXFDA,BSDXIENS
    130132        S BSDXIENS="+1,"
    131133        S BSDXFDA(9002018.4,BSDXIENS,.01)=BSDXBEG
    … …  
    137139        ;
    138140        K BSDXIEN
     141        ;
    139142        D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
    140143        S BSDXIEN=+$G(BSDXIEN(1))
    141         I '+BSDXIEN Q 0
     144        I '+BSDXIEN L -@REF Q 0
    142145        ;
    143146        ;Add WP field
    144147        I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE="" D
    145148        . D WP^DIE(9002018.4,BSDXIEN_",",1,"","BSDXNOTE","BSDXMSG")
     149        L -@REF
    146150        ;
    147151        Q 1
    148152        ;
    149153ERR(BSDXI,BSDXCNT,BSDXERR)      ;Error processing
    150         S BSDXI=BSDXI+1
    151            S BSDXERR=$TR(BSDXERR,"^","~")
     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,"^","~")
    152158        S ^BSDXTMP($J,BSDXI)=BSDXCNT_"^"_BSDXERR_$C(30)
    153159        S BSDXI=BSDXI+1
    … …  
    157163ETRAP   ;EP Error trap entry
    158164        ; No Txn here. So don't rollback anything
    159            N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
    160            D ^%ZTER
    161            S $EC="" ; Clear error
     165        N $ET S $ET="D ^%ZTER HALT" ; Emergency Error Trap
     166        D ^%ZTER
     167        S $EC="" ; Clear error
    162168        I '$D(BSDXI) N BSDXI S BSDXI=0
    163169        D ERR(BSDXI,$G(BSDXCNT),"~100~BSDX29, Error: "_$G(%ZTERZE))

  • Scheduling/trunk/m/BSDX2E.m

    r1563 r1625  
    1 BSDX2E  ;IHS/OIT/MJL - ENVIRONMENT CHECK FOR WINDOWS SCHEDULING [4/28/11 10:28am]
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     1BSDX2E  ;IHS/OIT/MJL - ENVIRONMENT CHECK FOR WINDOWS SCHEDULING [7/11/12 9:37am]
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;
    … …  
    2424        Q:'$$VERCHK("SD",5.3)
    2525        ; Q:'$$PATCHCK("PIMS*5.3*1003") D
    26         Q:'$$VERCHK("BMX",2)
     26        Q:'$$VERCHK("BMX",4)
    2727        ;
    2828OTHER   ;
    … …  
    9191        . D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
    9292        . ; Error message
    93         . I $D(BSDXMSG) W $C(7),"Error: ",BSDXMSG("DIERR",1,"TEXT",1)
     93        . I $D(BSDXMSG) D MES^XPDUTL("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) W $C(7),"Error: ",BSDXMSG("DIERR",1,"TEXT",1)
     108        I $D(BSDXMSG) D MES^XPDUTL("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) W $C(7),"Error: ",BSDXERR
     119        I $G(BSDXERR) D MES^XPDUTL("Error: ",BSDXERR)
    120120        QUIT
    121121        ;

  • Scheduling/trunk/m/BSDX30.m

    r1563 r1625  
    1 BSDX30  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; [4/28/11 10:28am]
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     1BSDX30  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; [7/6/12 11:03am]
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    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.
    7275        ;
    7376        ;Change patient context to patient DFN
    … …  
    7881        ;all EHR client sessions belonging to user DUZ.
    7982        ;
    80         Q:'$G(DUZ)
     83        ;Q:'$G(DUZ)
    8184        ;N X
    8285        ;S X="CIANBUTL" X ^%ZOSF("TEST") Q:'$T
    8386        ;S X="CIANBEVT" X ^%ZOSF("TEST") Q:'$T
    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
     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

  • Scheduling/trunk/m/BSDX31.m

    r1563 r1625  
    1 BSDX31   ; 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            ;
     1BSDX31   ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/10/12 10:39am
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
     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        ;
    1926NOSHOWD(BSDXY,BSDXAPTID,BSDXNS) ;EP
    20            ;Entry point for debugging
    21            ;
    22            D DEBUG^%Serenji("NOSHOW^BSDX31(.BSDXY,BSDXAPTID,BSDXNS)")
    23            Q
    24            ;
    25 UT      ; 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
     27        ;Entry point for debugging
     28        ;
     29        ; D DEBUG^%Serenji("NOSHOW^BSDX31(.BSDXY,BSDXAPTID,BSDXNS)")
     30        Q
     31        ;
    5832NOSHOW(BSDXY,BSDXAPTID,BSDXNS)          ;EP - No show a patient
    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            ;
    123 APNOSHO(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            ;
    146 BSDXNOS(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            ;
     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        ;
     132BSDXNOS(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        ;
    154144NOSEVT(BSDXPAT,BSDXSTART,BSDXSC)           ;EP Called by BSDX NOSHOW APPOINTMENT event
    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            ;
     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        ;
    171161NOSEVT1(BSDXRES,BSDXSTART,BSDXPAT,BSDXSTAT)     ;
    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            ;
     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        ;
    185176NOSEVT3(BSDXRES)           ;
    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            ;
     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        ;
    196187ERR(BSDXERID,ERRTXT)       ;Error processing
    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            ;
     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        ;
    205199ETRAP     ;EP Error trap entry
    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            ;
     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        ;
    216208IMHERE(BSDXRES) ;EP
    217            ;Entry point for BSDX IM HERE remote procedure
    218            S BSDXRES=1
    219            Q
    220            ;
     209        ;Entry point for BSDX IM HERE remote procedure
     210        S BSDXRES=1
     211        Q
     212        ;

  • Scheduling/trunk/m/BSDX32.m

    r1563 r1625  
    11BSDX32  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 5/11/11 10:39am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDX33.m

    r1563 r1625  
    11BSDX33  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:29am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ; Mods by WV/STAR

  • Scheduling/trunk/m/BSDX34.m

    r1563 r1625  
    11BSDX34  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:29am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL 
    44        ;

  • Scheduling/trunk/m/BSDX35.m

    r1563 r1625  
    1 BSDX35  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 4/28/11 10:29am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     1BSDX35  ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 6/21/12 3:57pm
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL 
    44        ;

  • Scheduling/trunk/m/BSDXAPI.m

    r1563 r1625  
    1 BSDXAPI ; IHS/ANMC/LJF & VW/SMH - SCHEDULING APIs ; 4/28/11 10:30am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     1BSDXAPI ; IHS/LJF,HMW,MAW & VEN/SMH - SCHEDULING APIs ; 7/10/12 5:58pm
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL 
    44        ;
    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         ; 
     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).
    359        ;
    3610MAKE1(DFN,CLIN,TYP,DATE,LEN,INFO)       ; Simplified PEP w/ parameters for $$MAKE - making appointment
    … …  
    3913        ; for Baby foxes hallucinations.
    4014        ; S RESULT=$$MAKE1^BSDXAPI(23435,33,(3 or 4),3091220.221159,30,"I see Baby foxes")
     15        N BSDR
    4116        S BSDR("PAT")=DFN       ;DFN
    4217        S BSDR("CLN")=CLIN      ;Hosp Loc IEN
    … …  
    6540        ;   = 1^message:  error and reason
    6641        ;
     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        ;
     123MAKECK(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        ;
    67128        I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))
    68129        I '$D(^SC(+$G(BSDR("CLN")),0)) Q 1_U_"Clinic not on file: "_$G(BSDR("CLN"))
    … …  
    71132        I $G(BSDR("ADT"))'?7N.1".".4N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT"))
    72133        ;
    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.
     134        ; Appt Length check removed in v 1.5
     135        ;
    74136        I '$D(^VA(200,+$G(BSDR("USR")),0)) Q 1_U_"User Who Made Appt Error: "_$G(BSDR("USR"))
    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         ;
     137        ; More verbose error message in v1.5
    77138        ; Following block to give an error message to user if there is already an appointment for patient. More verbose than others.
    78139        N BSDXERR ; place to store error message
    … …  
    88149        . . N BSDXRESNAM S BSDXRESNAM=$P(^BSDXRES(BSDXRESIEN,0),U)
    89150        . . 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)
    150         Q 0
     151        Q 0
     152        ;
     153UNMAKE(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
    151178        ;
    152179CHECKIN1(DFN,CLIN,APDATE)       ; Simplified PEP w/ parameters for $$CHECKIN - Checking in
    … …  
    154181        ; for appt at Dec 20, 2009 @ 10:11:59
    155182        ; S RESULT=$$CHECKIN1^BSDXAPI(23435,33,3091220.221159)
     183        N BSDR
    156184        S BSDR("PAT")=DFN          ;DFN
    157185        S BSDR("CLN")=CLIN         ;Hosp Loc IEN
    … …  
    175203        ;              = 0 means everything worked
    176204        ;              = 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        ;
     251CHECKIC1(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        ;
     264CHECKICK(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"
    177269        ;
    178270        I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))
    … …  
    185277        ;
    186278        ; find ien for appt in file 44
    187         NEW IEN,DIE,DA,DR
    188         S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
     279        N IEN S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
    189280        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)
    210281        Q 0
    211282        ;
    … …  
    216287        ; because foxes come out during bad weather.
    217288        ; S RESULT=$$CANCEL1^BSDXAPI(23435,33,"PC",3091220.221159,1,"Afraid of foxes")
     289        N BSDR
    218290        S BSDR("PAT")=DFN
    219291        S BSDR("CLN")=CLIN
    … …  
    244316        ;   = 1^message:  error and reason
    245317        ;
     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        ;
     379CANCELCK(BSDR)  ; $$ PEP; Okay to Cancel Appointment?
     380        ; Input: .BSDR array as documented in $$CANCEL
     381        ; Output: 0 or 1^Error message
    246382        I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))
    247383        I '$D(^SC(+$G(BSDR("CLN")),0)) Q 1_U_"Clinic not on file: "_$G(BSDR("CLN"))
    … …  
    254390        I '$D(^SD(409.2,+$G(BSDR("CR")))) Q 1_U_"Cancel Reason error: "_$G(BSDR("CR"))
    255391        ;
    256         NEW IEN,DIE,DA,DR
    257         S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
     392        NEW IEN S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
    258393        I 'IEN Q 1_U_"Error trying to find appointment for cancel: Patient="_BSDR("PAT")_" Clinic="_BSDR("CLN")_" Appt="_BSDR("ADT")
    259394        ;
    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)
     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!"
    295397        Q 0
    296398        ;
    … …  
    302404        Q $S(X:1,1:0)
    303405        ;
    304 RMCI(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
     406CO(PAT,CLINIC,DATE,SDIEN)       ;PEP; -- returns 1 if appt already checked-out
     407        NEW X
     408        S X=$G(SDIEN)   ;ien sent in call
     409        I 'X S X=$$SCIEN(PAT,CLINIC,DATE) I 'X Q 0
     410        S X=$P($G(^SC(CLINIC,"S",DATE,1,X,"C")),U,3)
     411        Q $S(X:1,1:0)
    342412        ;
    343413SCIEN(PAT,CLINIC,DATE)  ;PEP; returns ien for appt in ^SC
    … …  
    348418        Q $G(IEN)
    349419        ;
     420APPLEN(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
    350425APPTYP(PAT,DATE)        ;PEP; -- returns type of appt (scheduled or walk-in)
    351426        NEW X S X=$P($G(^DPT(PAT,"S",DATE,0)),U,7)
    352427        Q $S(X=3:"SCHED",X=4:"WALK-IN",1:"??")
    353428        ;
    354 CO(PAT,CLINIC,DATE,SDIEN)       ;PEP; -- returns 1 if appt already checked-out
    355         NEW X
    356         S X=$G(SDIEN)   ;ien sent in call
    357         I 'X S X=$$SCIEN(PAT,CLINIC,DATE) I 'X Q 0
    358         S X=$P($G(^SC(CLINIC,"S",DATE,1,X,"C")),U,3)
    359         Q $S(X:1,1:0)
    360         ;
    361 UPDATENOTE(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

    r1563 r1625  
    11BSDXAPI1        ; VEN/SMH - SCHEDULING APIs - Continued!!! ; 7/9/12 2:22pm
    2         ;;1.7;BSDX;;Oct 04, 2012;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL 
    44        ;

  • Scheduling/trunk/m/BSDXGPRV.m

    r1563 r1625  
    1 BSDXGPRV        ; WV/SMH - WINDOWS SCHEDULING RPCS ; 4/28/11 10:31am
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 25
     1BSDXGPRV        ; WV/SMH - WINDOWS SCHEDULING RPCS ; 7/6/12 11:07am
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    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

    r1563 r1625  
    11BSDXUT  ; VEN/SMH - Unit Tests for Scheduling GUI ; 6/29/12 12:20pm
    2         ;;1.7;BSDX;;Oct 04, 2012;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ; Licensed under LGPL
    44        ;

  • Scheduling/trunk/m/BSDXUT1.m

    r1563 r1625  
    11BSDXUT1 ; VEN/SMH - Unit Tests for Scheduling GUI - cont. ; 7/9/12 12:31pm
    2         ;;1.7;BSDX;;Oct 04, 2012;Build 25
     2        ;;1.7;BSDX;;Jun 01, 2013;Build 24
    33        ;
    44        ;

  • Scheduling/trunk/m/BSDXUT2.m

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