Changeset 1451


Ignore:
Timestamp:
Jun 19, 2012, 8:19:03 PM (12 years ago)
Author:
Sam Habiel
Message:

removed transactions from BSDX07... still more work to be done though

Location:
Scheduling/trunk/m
Files:
2 edited

Legend:

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

    r1450 r1451  
    1 BSDX07  ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS  ; 6/18/12 5:12pm
     1BSDX07  ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS  ; 6/19/12 5:34pm
    22        ;;1.7T1;BSDX;;Aug 31, 2011;Build 18
    33        ; Licensed under LGPL
     
    2828APPADDD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)       ;EP
    2929        ;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     ; Set-up - Create Clinics
     30        ; D DEBUG^%Serenji("APPADD^BSDX07(.BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID)")
     31        Q
     32        ;
     33UT      ; Unit Tests - Assumes you have Patients with DFNs 1,2 and 3
     34        ; Set-up - Create Clinics
    3535        N RESNAM S RESNAM="UTCLINIC"
    36     N HLRESIENS ; holds output of UTCR^BSDX35 - HL IEN^Resource IEN
    37     D
    38     . N $ET S $ET="D ^%ZTER B"
     36        N HLRESIENS ; holds output of UTCR^BSDX35 - HL IEN^Resource IEN
     37        D
     38        . N $ET S $ET="D ^%ZTER B"
    3939        . S HLRESIENS=$$UTCR^BSDX35(RESNAM)
    40     . I HLRESIENS<0 S $EC=",U1," ; not supposed to happen
    41     ;
    42     N HLIEN,RESIEN
    43     S HLIEN=$P(HLRESIENS,U)
    44     S RESIEN=$P(HLRESIENS,U,2)
    45     ;
    46     ; Get start and end times
    47     N TIMES S TIMES=$$TIMES^BSDX35 ; appt time^end time
    48     N APPTTIME S APPTTIME=$P(TIMES,U)
    49     N ENDTIME S ENDTIME=$P(TIMES,U,2)
    50     ;
    51         N ZZZ
     40        . I HLRESIENS<0 S $EC=",U1," ; not supposed to happen
     41        ;
     42        N HLIEN,RESIEN
     43        S HLIEN=$P(HLRESIENS,U)
     44        S RESIEN=$P(HLRESIENS,U,2)
     45        ;
     46        ; Get start and end times
     47        N TIMES S TIMES=$$TIMES^BSDX35 ; appt time^end time
     48        N APPTTIME S APPTTIME=$P(TIMES,U)
     49        N ENDTIME S ENDTIME=$P(TIMES,U,2)
     50        ;
     51        N ZZZ,DFN
    5252        ; Test for normality:
    53         D APPADD(.ZZZ,APPTTIME,ENDTIME,3,RESNAM,30,"Sam's Note",1)
     53        S DFN=3
     54        D APPADD(.ZZZ,APPTTIME,ENDTIME,DFN,RESNAM,30,"Sam's Note",1)
    5455        ; Does Appt exist?
    5556        N APPID S APPID=+$P(^BSDXTMP($J,1),U)
    5657        I 'APPID W "Error Making Appt-1" QUIT
    5758        I +^BSDXAPPT(APPID,0)'=APPTTIME W "Error Making Appt-2"
    58         I '$D(^DPT(3,"S",APPTTIME)) W "Error Making Appt-3"
    59         I '$D(^SC(HLIEN,"S",APPTTIME)) W "Error Making Appt-4"
    60     ;
    61     ; Do it again for a different patient
    62         D APPADD(.ZZZ,APPTTIME,ENDTIME,2,RESNAM,30,"Sam's Note",1)
    63         N APPID S APPID=+$P(^BSDXTMP($J,1),U) B
     59        I '$D(^DPT(DFN,"S",APPTTIME)) W "Error Making Appt-3"
     60        I '$$SCIEN^BSDXAPI(DFN,HLIEN,APPTTIME) W "Error Making Appt-4"
     61        ;
     62        ; Do it again for a different patient
     63        S DFN=2
     64        D APPADD(.ZZZ,APPTTIME,ENDTIME,DFN,RESNAM,30,"Sam's Note",1)
     65        N APPID S APPID=+$P(^BSDXTMP($J,1),U)
    6466        I 'APPID W "Error Making Appt-5" QUIT
    6567        I +^BSDXAPPT(APPID,0)'=APPTTIME W "Error Making Appt-6"
    66         I '$D(^DPT(2,"S",APPTTIME)) W "Error Making Appt-7"
    67         I '$D(^SC(HLIEN,"S",APPTTIME)) W "Error Making Appt-8"
    68     ;
     68        I '$D(^DPT(DFN,"S",APPTTIME)) W "Error Making Appt-7"
     69        I '$$SCIEN^BSDXAPI(DFN,HLIEN,APPTTIME) W "Error Making Appt-8"
     70        ;
     71        ; Again for a different patient (4)
     72        S DFN=4
     73        D APPADD(.ZZZ,APPTTIME,ENDTIME,DFN,RESNAM,30,"Sam's Note",1)
     74        N APPID S APPID=+$P(^BSDXTMP($J,1),U)
     75        I 'APPID W "Error Making Appt-9" QUIT
     76        I +^BSDXAPPT(APPID,0)'=APPTTIME W "Error Making Appt-10"
     77        I '$D(^DPT(DFN,"S",APPTTIME)) W "Error Making Appt-11"
     78        I '$$SCIEN^BSDXAPI(DFN,HLIEN,APPTTIME) W "Error Making Appt-12"
     79        ;
     80        ; Delete appointment set for Patient 4 (made above)
     81        N BSDX,DFN
     82        S DFN=4
     83        S BSDX("PAT")=DFN
     84        S BSDX("CLN")=HLIEN
     85        S BSDX("ADT")=APPTTIME
     86        D BSDXDEL^BSDX07(APPID)
     87        S %=$$UNMAKE^BSDXAPI(.BSDX)
     88        I +$G(^BSDXAPPT(APPID,0)) W "Error in deleting appointment-1",!
     89        I $D(^DPT(DFN,"S",APPTTIME)) W "Error in deleting appointment-2",!
     90        I $$SCIEN^BSDXAPI(DFN,HLIEN,APPTTIME) W "Error in deleting appointment-3",!
     91        ;
     92        ; Delete appointment set for Patient 1 (not made)... needs to not crash
     93        D
     94        . N $ET S $ET="D ^%ZTER S $EC="""" W ""Failure to del non-existent appt"",!"
     95        . D BSDXDEL^BSDX07(9999999)
     96        . N BSDX
     97        . S BSDX("PAT")=1
     98        . S BSDX("CLN")=HLIEN
     99        . S BSDX("ADT")=APPTTIME
     100        . S %=$$UNMAKE^BSDXAPI(.BSDX)
     101        ;
    69102        ; Test for bad start date
    70103        D APPADD(.ZZZ,2100123,3100123.3,2,RESNAM,30,"Sam's Note",1)
     
    81114        I +$P(^BSDXTMP($J,1),U,2)'=-100 W "Error in -100: M Error",!
    82115        K BSDXDIE
    83         ; Test for TRESTART
    84         s BSDXRESTART=1
    85         D APPADD(.ZZZ,APPTTIME,ENDTIME,3,RESNAM,30,"Sam's Note",1)
    86         I +$P(^BSDXTMP($J,1),U,2)'=0&(+$P(^BSDXTMP($J,1),U,2)'=-10) W "Error in TRESTART",!
    87         k BSDXRESTART
     116        ; Test for TRESTART -- retired in v 1.7
     117        ; S BSDXRESTART=1
     118        ; D APPADD(.ZZZ,APPTTIME,ENDTIME,3,RESNAM,30,"Sam's Note",1)
     119        ; I +$P(^BSDXTMP($J,1),U,2)'=0&(+$P(^BSDXTMP($J,1),U,2)'=-10) W "Error in TRESTART",!
     120        ; K BSDXRESTART
    88121        ; Test for non-numeric patient
    89122        D APPADD(.ZZZ,APPTTIME,ENDTIME,"CAT,DOG",RESNAM,30,"Sam's Note",1)
     
    97130        ; Test for corrupted resource
    98131        ; Can't test for -8 since it requires DB corruption
    99         ; Test for inability to add appointment to BSDX Appointment
     132        ; Test for inability to add appointment to BSDX Appointment (-9)
    100133        ; Also requires something wrong in the DB
    101134        ; Test for inability to add appointment to 2,44
    102135        ; Test by creating a duplicate appointment
    103     ; Get start and end times
    104     N TIMES S TIMES=$$TIMES^BSDX35 ; appt time^end time
    105     N APPTTIME S APPTTIME=$P(TIMES,U)
    106     N ENDTIME S ENDTIME=$P(TIMES,U,2)
     136        ; Get start and end times
     137        N TIMES S TIMES=$$TIMES^BSDX35 ; appt time^end time
     138        N APPTTIME S APPTTIME=$P(TIMES,U)
     139        N ENDTIME S ENDTIME=$P(TIMES,U,2)
    107140        D APPADD(.ZZZ,APPTTIME,ENDTIME,3,RESNAM,30,"Sam's Note",1)
    108141        D APPADD(.ZZZ,APPTTIME,ENDTIME,3,RESNAM,30,"Sam's Note",1)
     
    111144        ;
    112145APPADD(BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXRADEXAM) ;EP
    113            ;
    114            ;Called by RPC: BSDX ADD NEW APPOINTMENT
    115            ;
    116            ;Add new appointment to 3 files
    117            ; - BSDX APPOINTMENT
    118            ; - Hosp Location Appointment SubSubfile if Resource is linked to clinic
    119            ; - Patient Appointment Subfile if Resource is linked to clinic
    120            ;
    121            ;Paramters:
    122            ;BSDXY: Global Return (RPC must be set to Global Array)
    123            ;BSDXSTART: FM Start Date
    124            ;BSDXEND: FM End Date
    125            ;BSDXPATID: Patient DFN
    126            ;BSDXRES is ResourceName in BSDX RESOURCE file (not IEN)
    127            ;BSDXLEN is the appointment duration in minutes
    128            ;BSDXNOTE is the Appiontment Note
    129            ;BSDXATID is used for 2 purposes:
    130            ; if BSDXATID = "WALKIN" then BSDAPI is called to create a walkin appt.
    131            ; if BSDXATID = a number, then it is the access type id (used for rebooking)
    132            ;BSDXRADEXAM is used to store the Radiology Exam to which this appointment is tied to (optional)
    133            ;
    134            ;Return:
    135            ; ADO.net Recordset having fields:
    136            ; AppointmentID and ErrorNumber
    137            ;
    138            ;Test lines:
    139            ;BSDX ADD NEW APPOINTMENT^3091122.0930^3091122.1000^370^Dr Office^30^EXAM^WALKIN
    140            ;
    141            ; Deal with optional arguments
    142            S BSDXRADEXAM=$G(BSDXRADEXAM)
    143            ; Return Array; set Return and clear array
    144            S BSDXY=$NA(^BSDXTMP($J))
    145            K ^BSDXTMP($J)
    146            ; $ET
    147            N $ET S $ET="G ETRAP^BSDX07"
    148            ; Counter
    149            N BSDXI S BSDXI=0
    150            ; Lock BSDX node, only to synchronize access to the globals.
    151            ; It's not expected that the error will ever happen as no filing
    152            ; is supposed to take 5 seconds.
    153            L +^BSDXAPPT(BSDXPATID):5 I '$T D ERR(BSDXI,"-1~Patient record is locked. Please contact technical support.") Q
    154            ; Header Node
    155            S ^BSDXTMP($J,BSDXI)="I00020APPOINTMENTID^T00100ERRORID"_$C(30)
    156            ;Restartable Transaction; restore paramters when starting.
    157            ; (Params restored are what's passed here + BSDXI)
    158            TSTART (BSDXY,BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXLEN,BSDXNOTE,BSDXATID,BSDXI):T="BSDX ADD NEW APPOINTMENT^BSDX07"
    159            ;
    160            ; Turn off SDAM APPT PROTOCOL BSDX Entries
    161            N BSDXNOEV
    162            S BSDXNOEV=1 ;Don't execute BSDX ADD APPOINTMENT protocol
    163            ;
    164            ; Set Error Message to be empty
    165            N BSDXERR S BSDXERR=0
    166            ;
    167            ;;;test for error inside transaction. See if %ZTER works
    168            I $G(BSDXDIE) S X=1/0
    169            ;;;test
    170            ;;;test for TRESTART
    171            I $G(BSDXRESTART) K BSDXRESTART TRESTART
    172            ;;;test
    173            ;
    174            ; -- Start and End Date Processing --
    175            ; If C# sends the dates with extra zeros, remove them
    176            S BSDXSTART=+BSDXSTART,BSDXEND=+BSDXEND
    177            ; Are the dates valid? Must be FM Dates > than 2010
    178            I BSDXSTART'>3100000 D ERR(BSDXI,"-2~BSDX07 Error: Invalid Start Time") Q
    179            I BSDXEND'>3100000 D ERR(BSDXI,"-3~BSDX07 Error: Invalid End Time") Q
    180            ;
    181            ;; If Ending date doesn't have a time, this is an error --rm 1.5
    182            ; I $L(BSDXEND,".")=1 D ERR(BSDXI,"-4~BSDX07 Error: Invalid End Time") Q
    183            ;
    184            ; If the Start Date is greater than the end date, swap dates
    185            N BSDXTMP
    186            I BSDXSTART>BSDXEND S BSDXTMP=BSDXEND,BSDXEND=BSDXSTART,BSDXSTART=BSDXTMP
    187            ;
    188            ; Check if the patient exists:
    189            ; - DFN valid number?
    190            ; - Valid Patient in file 2?
    191            I '+BSDXPATID D ERR(BSDXI,"-5~BSDX07 Error: Invalid Patient ID") Q
    192            I '$D(^DPT(BSDXPATID,0)) D ERR(BSDXI,"-6~BSDX07 Error: Invalid Patient ID") Q
    193            ;
    194            ;Validate Resource entry
    195            I '$D(^BSDXRES("B",BSDXRES)) D ERR(BSDXI,"-7~BSDX07 Error: Invalid Resource ID") Q
    196            N BSDXRESD ; Resource IEN
    197            S BSDXRESD=$O(^BSDXRES("B",BSDXRES,0))
    198            N BSDXRNOD ; Resouce zero node
    199            S BSDXRNOD=$G(^BSDXRES(BSDXRESD,0))
    200            I BSDXRNOD="" D ERR(BSDXI,"-8~BSDX07 Error: invalid Resource entry.") Q
    201            ;
    202            ; Walk-in (Unscheduled) Appointment?
    203            N BSDXWKIN S BSDXWKIN=0
    204            I BSDXATID="WALKIN" S BSDXWKIN=1
    205            ; Reset Access Type ID if it doesn't say "WALKIN" and isn't a number
    206            I BSDXATID'?.N&(BSDXATID'="WALKIN") S BSDXATID=""
    207            ;
    208            ; Done with all checks, let's make appointment in BSDX APPOINTMENT
    209            N BSDXAPPTID
    210            S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM)
    211            I 'BSDXAPPTID D ERR(BSDXI,"-9~BSDX07 Error: Unable to add appointment to BSDX APPOINTMENT file.") Q
    212            I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
    213            ;
    214            ; Then Create Subfiles in 2/44 Appointment
    215            N BSDXSCD S BSDXSCD=$P(BSDXRNOD,U,4)  ; Hosp Location IEN
    216            ; Only if we have a valid Hosp Loc can we make an appointment
    217            I +BSDXSCD,$D(^SC(BSDXSCD,0)) D  I +BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: MAKE^BSDXAPI returned error code: "_BSDXERR) Q
    218            . N BSDXC
    219            . S BSDXC("PAT")=BSDXPATID
    220            . S BSDXC("CLN")=BSDXSCD
    221            . S BSDXC("TYP")=3 ;3 for scheduled appts, 4 for walkins
    222            . S:BSDXWKIN BSDXC("TYP")=4
    223            . S BSDXC("ADT")=BSDXSTART
    224            . S BSDXC("LEN")=BSDXLEN
    225            . S BSDXC("OI")=$E($G(BSDXNOTE),1,150) ;File 44 has 150 character limit on OTHER field
    226            . S BSDXC("OI")=$TR(BSDXC("OI"),";"," ") ;No semicolons allowed by MAKE^BSDXAPI
    227            . S BSDXC("OI")=$$STRIP(BSDXC("OI")) ;Strip control characters from note
    228            . S BSDXC("USR")=DUZ
    229            . S BSDXERR=$$MAKE^BSDXAPI(.BSDXC)
    230            . Q:BSDXERR
    231            . ;Update RPMS Clinic availability
    232            . D AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)
    233            . Q
    234            ;
    235            ;Return Recordset
    236            TCOMMIT
    237            L -^BSDXAPPT(BSDXPATID)
    238            S BSDXI=BSDXI+1
    239            S ^BSDXTMP($J,BSDXI)=BSDXAPPTID_"^"_$C(30)
    240            S BSDXI=BSDXI+1
    241            S ^BSDXTMP($J,BSDXI)=$C(31)
    242            Q
    243 BSDXDEL(BSDXAPPTID)     ;Deletes appointment BSDXAPPTID from BSDXAPPOINTMETN
    244            N DA,DIK
    245            S DIK="^BSDXAPPT(",DA=BSDXAPPTID
    246            D ^DIK
    247            Q
    248            ;
     146        ;
     147        ;Called by RPC: BSDX ADD NEW APPOINTMENT
     148        ;
     149        ;Add new appointment to 3 files
     150        ; - BSDX APPOINTMENT
     151        ; - Hosp Location Appointment SubSubfile if Resource is linked to clinic
     152        ; - Patient Appointment Subfile if Resource is linked to clinic
     153        ;
     154        ;Paramters:
     155        ;BSDXY: Global Return (RPC must be set to Global Array)
     156        ;BSDXSTART: FM Start Date
     157        ;BSDXEND: FM End Date
     158        ;BSDXPATID: Patient DFN
     159        ;BSDXRES is ResourceName in BSDX RESOURCE file (not IEN)
     160        ;BSDXLEN is the appointment duration in minutes
     161        ;BSDXNOTE is the Appiontment Note
     162        ;BSDXATID is used for 2 purposes:
     163        ; if BSDXATID = "WALKIN" then BSDAPI is called to create a walkin appt.
     164        ; if BSDXATID = a number, then it is the access type id (used for rebooking)
     165        ;BSDXRADEXAM is used to store the Radiology Exam to which this appointment is tied to (optional)
     166        ;
     167        ;Return:
     168        ; ADO.net Recordset having fields:
     169        ; AppointmentID and ErrorNumber
     170        ;
     171        ;Test lines:
     172        ;BSDX ADD NEW APPOINTMENT^3091122.0930^3091122.1000^370^Dr Office^30^EXAM^WALKIN
     173        ;
     174        ; Deal with optional arguments
     175        S BSDXRADEXAM=$G(BSDXRADEXAM)
     176    ;
     177        ; Return Array; set Return and clear array
     178        S BSDXY=$NA(^BSDXTMP($J))
     179        K ^BSDXTMP($J)
     180    ;
     181        ; $ET
     182        N $ET S $ET="G ETRAP^BSDX07"
     183        ;
     184        ; Counter
     185        N BSDXI S BSDXI=0
     186        ;
     187        ; Lock BSDX node, only to synchronize access to the globals.
     188        ; It's not expected that the error will ever happen as no filing
     189        ; is supposed to take 5 seconds.
     190        L +^BSDXAPPT(BSDXPATID):5 I '$T D ERR(BSDXI,"-1~Patient record is locked. Please contact technical support.") Q
     191        ;
     192        ; Header Node
     193        S ^BSDXTMP($J,BSDXI)="I00020APPOINTMENTID^T00100ERRORID"_$C(30)
     194        ;
     195        ; Turn off SDAM APPT PROTOCOL BSDX Entries
     196        N BSDXNOEV
     197        S BSDXNOEV=1 ;Don't execute BSDX ADD APPOINTMENT protocol
     198        ;
     199        ; Set Error Message to be empty
     200        N BSDXERR S BSDXERR=0
     201        ;
     202        ;;;test for error inside transaction. See if %ZTER works
     203        I $G(BSDXDIE) S X=1/0
     204        ;;;test
     205        ;
     206        ; -- Start and End Date Processing --
     207        ; If C# sends the dates with extra zeros, remove them
     208        S BSDXSTART=+BSDXSTART,BSDXEND=+BSDXEND
     209        ; Are the dates valid? Must be FM Dates > than 2010
     210        I BSDXSTART'>3100000 D ERR(BSDXI,"-2~BSDX07 Error: Invalid Start Time") Q
     211        I BSDXEND'>3100000 D ERR(BSDXI,"-3~BSDX07 Error: Invalid End Time") Q
     212        ;
     213        ;; If Ending date doesn't have a time, this is an error --rm 1.5
     214        ; I $L(BSDXEND,".")=1 D ERR(BSDXI,"-4~BSDX07 Error: Invalid End Time") Q
     215        ;
     216        ; If the Start Date is greater than the end date, swap dates
     217        N BSDXTMP
     218        I BSDXSTART>BSDXEND S BSDXTMP=BSDXEND,BSDXEND=BSDXSTART,BSDXSTART=BSDXTMP
     219        ;
     220        ; Check if the patient exists:
     221        ; - DFN valid number?
     222        ; - Valid Patient in file 2?
     223        I '+BSDXPATID D ERR(BSDXI,"-5~BSDX07 Error: Invalid Patient ID") Q
     224        I '$D(^DPT(BSDXPATID,0)) D ERR(BSDXI,"-6~BSDX07 Error: Invalid Patient ID") Q
     225        ;
     226        ;Validate Resource entry
     227        I '$D(^BSDXRES("B",BSDXRES)) D ERR(BSDXI,"-7~BSDX07 Error: Invalid Resource ID") Q
     228        N BSDXRESD ; Resource IEN
     229        S BSDXRESD=$O(^BSDXRES("B",BSDXRES,0))
     230        N BSDXRNOD ; Resouce zero node
     231        S BSDXRNOD=$G(^BSDXRES(BSDXRESD,0))
     232        I BSDXRNOD="" D ERR(BSDXI,"-8~BSDX07 Error: invalid Resource entry.") Q
     233        ;
     234        ; Walk-in (Unscheduled) Appointment?
     235        N BSDXWKIN S BSDXWKIN=0
     236        I BSDXATID="WALKIN" S BSDXWKIN=1
     237        ; Reset Access Type ID if it doesn't say "WALKIN" and isn't a number
     238        I BSDXATID'?.N&(BSDXATID'="WALKIN") S BSDXATID=""
     239        ;
     240        ; Now, check if PIMS has any issues with us making the appt using MAKECK
     241        N BSDXSCD S BSDXSCD=$P(BSDXRNOD,U,4)  ; Hosp Location IEN
     242        N BSDXERR ; Variable to hold value of $$MAKE and $$MAKECK
     243        N BSDXC ; Array to send to MAKE and MAKECK APIs
     244        ; Only if we have a valid Hosp Location
     245        I +BSDXSCD,$D(^SC(BSDXSCD,0)) D
     246        . S BSDXC("PAT")=BSDXPATID
     247        . S BSDXC("CLN")=BSDXSCD
     248        . S BSDXC("TYP")=3 ;3 for scheduled appts, 4 for walkins
     249        . S:BSDXWKIN BSDXC("TYP")=4
     250        . S BSDXC("ADT")=BSDXSTART
     251        . S BSDXC("LEN")=BSDXLEN
     252        . S BSDXC("OI")=$E($G(BSDXNOTE),1,150) ;File 44 has 150 character limit on OTHER field
     253        . S BSDXC("OI")=$TR(BSDXC("OI"),";"," ") ;No semicolons allowed by MAKE^BSDXAPI
     254        . S BSDXC("OI")=$$STRIP(BSDXC("OI")) ;Strip control characters from note
     255        . S BSDXC("USR")=DUZ
     256        . S BSDXERR=$$MAKECK^BSDXAPI(.BSDXC)
     257        I +BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: MAKECK^BSDXAPI returned error code: "_BSDXERR) Q  ; no need for roll back
     258        ;
     259        ; Done with all checks, let's make appointment in BSDX APPOINTMENT
     260        N BSDXAPPTID
     261        S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM)
     262        I 'BSDXAPPTID D ERR(BSDXI,"-9~BSDX07 Error: Unable to add appointment to BSDX APPOINTMENT file.") Q  ; no roll back needed! No appts made.
     263        I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE) ; TODO: check for error and rollback
     264        ;
     265        ; Only if we have a valid Hosp Loc can we make an appointment in 2/44
     266        ; Use BSDXC array from before.
     267        ; NB: $$MAKE itself calls $$MAKECK to check again for being okay.
     268        I +BSDXSCD,$D(^SC(BSDXSCD,0)) D  I +BSDXERR D ERR(BSDXI,"-10~BSDX07 Error: MAKE^BSDXAPI returned error code: "_BSDXERR),ROLLBACK(BSDXAPPTID,.BSDXC) Q
     269        . S BSDXERR=$$MAKE^BSDXAPI(.BSDXC)
     270        . Q:BSDXERR
     271        . ;Update RPMS Clinic availability
     272        . D AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)
     273        ;
     274        ;Return Recordset
     275        L -^BSDXAPPT(BSDXPATID)
     276        S BSDXI=BSDXI+1
     277        S ^BSDXTMP($J,BSDXI)=BSDXAPPTID_"^"_$C(30)
     278        S BSDXI=BSDXI+1
     279        S ^BSDXTMP($J,BSDXI)=$C(31)
     280        Q
    249281STRIP(BSDXZ)       ;Replace control characters with spaces
    250            N BSDXI
    251            F BSDXI=1:1:$L(BSDXZ) I (32>$A($E(BSDXZ,BSDXI))) S BSDXZ=$E(BSDXZ,1,BSDXI-1)_" "_$E(BSDXZ,BSDXI+1,999)
    252            Q BSDXZ
    253            ;
     282        N BSDXI
     283        F BSDXI=1:1:$L(BSDXZ) I (32>$A($E(BSDXZ,BSDXI))) S BSDXZ=$E(BSDXZ,1,BSDXI-1)_" "_$E(BSDXZ,BSDXI+1,999)
     284        Q BSDXZ
     285        ;
    254286BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRESD,BSDXATID,BSDXRADEXAM)       ;ADD BSDX APPOINTMENT ENTRY
    255            ;Returns ien in BSDXAPPT or 0 if failed
    256            ;Create entry in BSDX APPOINTMENT
    257            N BSDXAPPTID
    258            S BSDXFDA(9002018.4,"+1,",.01)=BSDXSTART
    259            S BSDXFDA(9002018.4,"+1,",.02)=BSDXEND
    260            S BSDXFDA(9002018.4,"+1,",.05)=BSDXPATID
    261            S BSDXFDA(9002018.4,"+1,",.07)=BSDXRESD
    262            S BSDXFDA(9002018.4,"+1,",.08)=$G(DUZ)
    263            S BSDXFDA(9002018.4,"+1,",.09)=$$NOW^XLFDT
    264            S:BSDXATID="WALKIN" BSDXFDA(9002018.4,"+1,",.13)="y"
    265            S:BSDXATID?.N BSDXFDA(9002018.4,"+1,",.06)=BSDXATID
    266            S BSDXFDA(9002018.4,"+1,",.14)=$G(BSDXRADEXAM)
    267            N BSDXIEN,BSDXMSG
    268            D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
    269            S BSDXAPPTID=+$G(BSDXIEN(1))
    270            Q BSDXAPPTID
    271            ;
     287        ;Returns ien in BSDXAPPT or 0 if failed
     288        ;Create entry in BSDX APPOINTMENT
     289        N BSDXAPPTID
     290        S BSDXFDA(9002018.4,"+1,",.01)=BSDXSTART
     291        S BSDXFDA(9002018.4,"+1,",.02)=BSDXEND
     292        S BSDXFDA(9002018.4,"+1,",.05)=BSDXPATID
     293        S BSDXFDA(9002018.4,"+1,",.07)=BSDXRESD
     294        S BSDXFDA(9002018.4,"+1,",.08)=$G(DUZ)
     295        S BSDXFDA(9002018.4,"+1,",.09)=$$NOW^XLFDT
     296        S:BSDXATID="WALKIN" BSDXFDA(9002018.4,"+1,",.13)="y"
     297        S:BSDXATID?.N BSDXFDA(9002018.4,"+1,",.06)=BSDXATID
     298        S BSDXFDA(9002018.4,"+1,",.14)=$G(BSDXRADEXAM)
     299        N BSDXIEN,BSDXMSG
     300        D UPDATE^DIE("","BSDXFDA","BSDXIEN","BSDXMSG")
     301        S BSDXAPPTID=+$G(BSDXIEN(1))
     302        Q BSDXAPPTID
     303        ;
    272304BSDXWP(BSDXAPPTID,BSDXNOTE)     ;
    273            ;Add WP field
    274            I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE=""
    275            I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0)
    276            I $D(BSDXNOTE(.5)) D
    277            . D WP^DIE(9002018.4,BSDXAPPTID_",",1,"","BSDXNOTE","BSDXMSG")
    278            Q
    279            ;
     305        ;Add WP field
     306        N BSDXMSG
     307        I BSDXNOTE]"" S BSDXNOTE(.5)=BSDXNOTE,BSDXNOTE=""
     308        I $D(BSDXNOTE(0)) S BSDXNOTE(.5)=BSDXNOTE(0) K BSDXNOTE(0)
     309        I $D(BSDXNOTE(.5)) D
     310        . D WP^DIE(9002018.4,BSDXAPPTID_",",1,"","BSDXNOTE","BSDXMSG")
     311        Q
     312        ;
    280313ADDEVT(BSDXPATID,BSDXSTART,BSDXSC,BSDXSCDA)     ;EP
    281            ;Called by BSDX ADD APPOINTMENT protocol
    282            ;BSDXSC=IEN of clinic in ^SC
    283            ;BSDXSCDA=IEN for ^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA). Use to get Length & Note
    284            ;
    285            N BSDXNOD,BSDXLEN,BSDXAPPTID,BSDXNODP,BSDXWKIN,BSDXRES
    286            Q:+$G(BSDXNOEV)
    287            I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0))
    288            E  I $D(^BSDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0))
    289            Q:'+$G(BSDXRES)
    290            S BSDXNOD=$G(^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA,0))
    291            Q:BSDXNOD=""
    292            S BSDXNODP=$G(^DPT(BSDXPATID,"S",BSDXSTART,0))
    293            S BSDXWKIN=""
    294            S:$P(BSDXNODP,U,7)=4 BSDXWKIN="WALKIN" ;Purpose of Visit field of DPT Appointment subfile
    295            S BSDXLEN=$P(BSDXNOD,U,2)
    296            Q:'+BSDXLEN
    297            S BSDXEND=$$FMADD^XLFDT(BSDXSTART,0,0,BSDXLEN,0)
    298            S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXWKIN)
    299            Q:'+BSDXAPPTID
    300            S BSDXNOTE=$P(BSDXNOD,U,4)
    301            I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
    302            D ADDEVT3(BSDXRES)
    303            Q
    304            ;
     314        ;Called by BSDX ADD APPOINTMENT protocol
     315        ;BSDXSC=IEN of clinic in ^SC
     316        ;BSDXSCDA=IEN for ^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA). Use to get Length & Note
     317        ;
     318        N BSDXNOD,BSDXLEN,BSDXAPPTID,BSDXNODP,BSDXWKIN,BSDXRES
     319        Q:+$G(BSDXNOEV)
     320        I $D(^BSDXRES("ALOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ALOC",BSDXSC,0))
     321        E  I $D(^BSDXRES("ASSOC",BSDXSC)) S BSDXRES=$O(^BSDXRES("ASSOC",BSDXSC,0))
     322        Q:'+$G(BSDXRES)
     323        S BSDXNOD=$G(^SC(BSDXSC,"S",BSDXSTART,1,BSDXSCDA,0))
     324        Q:BSDXNOD=""
     325        S BSDXNODP=$G(^DPT(BSDXPATID,"S",BSDXSTART,0))
     326        S BSDXWKIN=""
     327        S:$P(BSDXNODP,U,7)=4 BSDXWKIN="WALKIN" ;Purpose of Visit field of DPT Appointment subfile
     328        S BSDXLEN=$P(BSDXNOD,U,2)
     329        Q:'+BSDXLEN
     330        S BSDXEND=$$FMADD^XLFDT(BSDXSTART,0,0,BSDXLEN,0)
     331        S BSDXAPPTID=$$BSDXADD(BSDXSTART,BSDXEND,BSDXPATID,BSDXRES,BSDXWKIN)
     332        Q:'+BSDXAPPTID
     333        S BSDXNOTE=$P(BSDXNOD,U,4)
     334        I BSDXNOTE]"" D BSDXWP(BSDXAPPTID,BSDXNOTE)
     335        D ADDEVT3(BSDXRES)
     336        Q
     337        ;
    305338ADDEVT3(BSDXRES)           ;
    306            ;Call RaiseEvent to notify GUI clients
    307            N BSDXRESN
    308            S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
    309            Q:BSDXRESN=""
    310            S BSDXRESN=$P(BSDXRESN,"^")
    311            ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
    312            D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
    313            Q
    314            ;
     339        ;Call RaiseEvent to notify GUI clients
     340        N BSDXRESN
     341        S BSDXRESN=$G(^BSDXRES(BSDXRES,0))
     342        Q:BSDXRESN=""
     343        S BSDXRESN=$P(BSDXRESN,"^")
     344        ;D EVENT^BSDX23("SCHEDULE-"_BSDXRESN,"","","")
     345        D EVENT^BMXMEVN("BSDX SCHEDULE",BSDXRESN)
     346        Q
     347        ;
    315348ERR(BSDXI,BSDXERR)       ;Error processing
    316            S BSDXI=BSDXI+1
    317            S BSDXERR=$TR(BSDXERR,"^","~")
    318            I $TL>0 TROLLBACK
    319            S ^BSDXTMP($J,BSDXI)="0^"_BSDXERR_$C(30)
    320            S BSDXI=BSDXI+1
    321            S ^BSDXTMP($J,BSDXI)=$C(31)
    322            L -^BSDXAPPT(BSDXPATID)
    323            Q
    324            ;
     349        S BSDXI=BSDXI+1
     350        S BSDXERR=$TR(BSDXERR,"^","~")
     351        S ^BSDXTMP($J,BSDXI)="0^"_BSDXERR_$C(30)
     352        S BSDXI=BSDXI+1
     353        S ^BSDXTMP($J,BSDXI)=$C(31)
     354        L -^BSDXAPPT(BSDXPATID)
     355        Q
     356        ;
     357ROLLBACK(BSDXAPPTID,BSDXC) ; Private EP; Roll back appointment set
     358        ; DO NOT USE except as an emergency measure - only if unforseen error occurs
     359        ; Input:
     360        ; Appointment ID to remove from ^BSDXAPPT
     361        ; BSDXC array (see array format in $$MAKE^BSDXAPI)
     362        D BSDXDEL^BSDX07(BSDXAPPTID)
     363        S:$D(BSDXC) %=$$UNMAKE^BSDXAPI(.BSDXC) ; rtn value always 0
     364        QUIT
     365        ;
     366BSDXDEL(BSDXAPPTID)     ;Private EP ; Deletes appointment BSDXAPPTID from ^BSDXAPPT
     367        ; DO NOT USE except in emergencies to roll back an appointment set
     368        N DA,DIK
     369        S DIK="^BSDXAPPT(",DA=BSDXAPPTID
     370        D ^DIK
     371        Q
     372        ;
    325373ETRAP     ;EP Error trap entry
    326            N $ET S $ET="D ^%ZTER HALT"  ; Emergency Error Trap
    327            ; Rollback, otherwise ^XTER will be empty from future rollback
    328            I $TL>0 TROLLBACK
    329            D ^%ZTER
    330            S $EC=""  ; Clear Error
    331            ; Log error message and send to client
    332            I '$D(BSDXI) N BSDXI S BSDXI=0
    333            D ERR(BSDXI,"-100~BSDX07 Error: "_$G(%ZTERZE))
    334            Q
    335            ;
     374        N $ET S $ET="D ^%ZTER HALT"  ; Emergency Error Trap
     375        D ^%ZTER
     376        S $EC=""  ; Clear Error
     377        ; Log error message and send to client
     378        I '$D(BSDXI) N BSDXI S BSDXI=0
     379        D ERR(BSDXI,"-100~BSDX07 Error: "_$G(%ZTERZE))
     380        Q
     381        ;
    336382DAY     ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
    337            ;
     383        ;
    338384DOW     S %=$E(X,1,3),Y=$E(X,4,5),Y=Y>2&'(%#4)+$E("144025036146",Y)
    339            F %=%:-1:281 S Y=%#4=1+1+Y
    340            S Y=$E(X,6,7)+Y#7
    341            Q
    342            ;
     385        F %=%:-1:281 S Y=%#4=1+1+Y
     386        S Y=$E(X,6,7)+Y#7
     387        Q
     388        ;
    343389AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)         ;Update RPMS Clinic availability
    344            ;SEE SDM1
    345            N Y,DFN
    346            N SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG
    347            N X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I
    348            S Y=BSDXSCD,DFN=BSDXPATID
    349            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
    350            ;Determine maximum days for scheduling
    351            S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
    352            S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
    353            S SDDATE=BSDXSTART
    354            S SDSDATE=SDDATE,SDDATE=SDDATE\1
    355 1        ;L  Q:$D(SDXXX)  S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0  S SC=+SC
    356            Q:$D(SDXXX)  S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0  S SC=+SC
    357            S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)
    358            S X2=SDEDT D C^%DTC S SDEDT=X
    359            S Y=BSDXSTART
     390        ;SEE SDM1
     391        N Y,DFN
     392        N SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG
     393        N X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I
     394        S Y=BSDXSCD,DFN=BSDXPATID
     395        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
     396        ;Determine maximum days for scheduling
     397        S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
     398        S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
     399        S SDDATE=BSDXSTART
     400        S SDSDATE=SDDATE,SDDATE=SDDATE\1
     4011 ;L  Q:$D(SDXXX)  S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0  S SC=+SC
     402        Q:$D(SDXXX)  S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0  S SC=+SC
     403        S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)
     404        S X2=SDEDT D C^%DTC S SDEDT=X
     405        S Y=BSDXSTART
    360406EN1     S (X,SD)=Y,SM=0 D DOW
    361 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,".")
    362            S S=BSDXLEN
    363            ;Check if BSDXLEN evenly divisible by appointment length
    364            S RPMSL=$P(SL,U)
    365            I BSDXLEN<RPMSL S BSDXLEN=RPMSL
    366            I BSDXLEN#RPMSL'=0 D
    367            . S BSDXINC=BSDXLEN\RPMSL
    368            . S BSDXINC=BSDXINC+1
    369            . S BSDXLEN=RPMSL*BSDXINC
    370            S SL=S_U_$P(SL,U,2,99)
    371 SC       S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) Q:SDLOCK>9
    372            L +^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC
    373            S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1)
    374            S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
    375            I (I<1!'$F(S,"["))&(S'["CAN") L -^SC(SC,"ST",$P(SD,"."),1) Q
    376            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
    377            ;
    378 SP       I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP
    379            S SDNOT=1
    380            S ABORT=0
    381            F I=ST+ST:SDDIF:SS-SDDIF D  Q:ABORT
    382            . S ST=$E(S,I+1) S:ST="" ST=" "
    383            . S Y=$E(STR,$F(STR,ST)-2)
    384            . I S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))) S ABORT=1 Q
    385            . I Y="" S ABORT=1 Q
    386            . 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
    387            . Q
    388            S ^SC(SC,"ST",$P(SD,"."),1)=S
    389            L -^SC(SC,"ST",$P(SD,"."),1)
    390            Q
     407S       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,".")
     408        S S=BSDXLEN
     409        ;Check if BSDXLEN evenly divisible by appointment length
     410        S RPMSL=$P(SL,U)
     411        I BSDXLEN<RPMSL S BSDXLEN=RPMSL
     412        I BSDXLEN#RPMSL'=0 D
     413        . S BSDXINC=BSDXLEN\RPMSL
     414        . S BSDXINC=BSDXINC+1
     415        . S BSDXLEN=RPMSL*BSDXINC
     416        S SL=S_U_$P(SL,U,2,99)
     417SC      S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) Q:SDLOCK>9
     418        L +^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC
     419        S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1)
     420        S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
     421        I (I<1!'$F(S,"["))&(S'["CAN") L -^SC(SC,"ST",$P(SD,"."),1) Q
     422        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
     423        ;
     424SP      I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP
     425        S SDNOT=1
     426        S ABORT=0
     427        F I=ST+ST:SDDIF:SS-SDDIF D  Q:ABORT
     428        . S ST=$E(S,I+1) S:ST="" ST=" "
     429        . S Y=$E(STR,$F(STR,ST)-2)
     430        . I S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))) S ABORT=1 Q
     431        . I Y="" S ABORT=1 Q
     432        . 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
     433        . Q
     434        S ^SC(SC,"ST",$P(SD,"."),1)=S
     435        L -^SC(SC,"ST",$P(SD,"."),1)
     436        Q
  • Scheduling/trunk/m/BSDXAPI.m

    r1450 r1451  
    1 BSDXAPI ; IHS/ANMC/LJF & VW/SMH - SCHEDULING APIs ; 6/18/12 5:31pm
    2         ;;1.6;BSDX;;Aug 31, 2011;Build 18
     1BSDXAPI ; IHS/ANMC/LJF & VW/SMH - SCHEDULING APIs ; 6/19/12 5:42pm
     2        ;;1.7T1;BSDX;;Aug 31, 2011;Build 18
    33        ; Licensed under LGPL 
    44        ;
     
    3232        ; More user friendly message if patient already has appointment in $$MAKE:
    3333        ;  Spits out pt name and user friendly date.
    34     ; 2012-06-18 (v 1.7)
     34        ; 2012-06-18 (v 1.7)
    3535        ; Removing transacions. Means that code SHOULD NOT fail. Took all checks
    36     ;  out for making an appointment to MAKECK. We call this first to make sure
    37     ; that the appointment is okay to make before committing to make it.
     36        ;  out for making an appointment to MAKECK. We call this first to make sure
     37        ; that the appointment is okay to make before committing to make it. We
     38        ; still have the provision to delete the data though if we fail when we
     39        ; actually make the appointment
    3840        ;
    3941MAKE1(DFN,CLIN,TYP,DATE,LEN,INFO)       ; Simplified PEP w/ parameters for $$MAKE - making appointment
     
    7072        N BSDXMKCK S BSDXMKCK=$$MAKECK(.BSDR) ; Check if we can make appointment
    7173        I BSDXMKCK Q BSDXMKCK ; If we can't, quit with the reason why.
    72     ; Otherwise, we continue
    73         ;
    74         NEW DIC,DA,Y,X,DD,DO,DLAYGO
     74        ;
     75        ;Otherwise, we continue
     76        ;
     77        N BSDXFDA,BSDXIENS,BSDXMSG ; FILE/UPDATE^DIE variables
    7578        ;
    7679        I $D(^DPT(BSDR("PAT"),"S",BSDR("ADT"),0)),$P(^(0),U,2)["C" D
    7780        . ; "un-cancel" existing appt in file 2
    78         . N BSDXFDA,BSDXIENS,BSDXMSG
    7981        . S BSDXIENS=BSDR("ADT")_","_BSDR("PAT")_","
    8082        . S BSDXFDA(2.98,BSDXIENS,".01")=BSDR("CLN")
     
    8890        . S BSDXFDA(2.98,BSDXIENS,"20")=$$NOW^XLFDT
    8991        . D FILE^DIE("","BSDXFDA","BSDXMSG")
    90         . N BSDXTEMP S BSDXTEMP=$G(BSDXMSG)
    91         E  D 
    92         . N BSDXFDA,BSDXIENS,BSDXMSG
     92        Q:$D(BSDXMSG) 1_U_"Fileman edit to DPT error: Patient="_BSDR("PAT")_" Appt="_BSDR("ADT")_" Error="_BSDXMSG("DIERR",1,"TEXT",1)
     93        ;
     94        E  D  ; File new appointment/edit existing appointment in file 2
    9395        . S BSDXIENS="?+2,"_BSDR("PAT")_","
    9496        . S BSDXIENS(2)=BSDR("ADT")
     
    9799        . S BSDXFDA(2.98,BSDXIENS,"9.5")=9
    98100        . S BSDXFDA(2.98,BSDXIENS,"20")=$$NOW^XLFDT
    99         . D UPDATE^DIE("","BSDXFDA","BSDXIENS","BSDXERR(1)")
    100         I $G(BSDXERR(1)) Q 1_U_"FileMan add to DPT error: Patient="_BSDR("PAT")_" Appt="_BSDR("ADT")
    101     ; add appt to file 44
    102         K DIC,DA,X,Y,DLAYGO,DD,DO
     101        . D UPDATE^DIE("","BSDXFDA","BSDXIENS","BSDXMSG")
     102        Q:$D(BSDXMSG) 1_U_"FileMan add to DPT error: Patient="_BSDR("PAT")_" Appt="_BSDR("ADT")_" Error="_BSDXMSG("DIERR",1,"TEXT",1)
     103        ;
     104        ; add appt to file 44. This adds it to the FIRST subfile (Appointment)
     105        N DIC,DA,Y,X,DD,DO,DLAYGO
    103106        I '$D(^SC(BSDR("CLN"),"S",0)) S ^SC(BSDR("CLN"),"S",0)="^44.001DA^^"
    104107        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")
     
    106109        . S DIC("P")="44.001DA",DIC(0)="L",DLAYGO=44.001
    107110        . S Y=1 I '$D(@(DIC_X_")")) D FILE^DICN
    108    
    109         ;
     111        ;
     112        ; add appt for file 44, second subfile (Appointment/Patient)
    110113        ; Sep 28 2010: Changed old style API to new style API. Keep for reference //smh
    111114        ;K DIC,DA,X,Y,DLAYGO,DD,DO,DINUM
     
    136139        ;
    137140MAKECK(BSDR) ; $$ - Is it okay to make an appointment? ; PEP
     141        ; Input: Same as $$MAKE
     142        ; Output: 1^error or 0 for success
     143        ; NB: This subroutine saves no data. Only checks whether it's okay.
     144        ;
    138145        I '$D(^DPT(+$G(BSDR("PAT")),0)) Q 1_U_"Patient not on file: "_$G(BSDR("PAT"))
    139146        I '$D(^SC(+$G(BSDR("CLN")),0)) Q 1_U_"Clinic not on file: "_$G(BSDR("CLN"))
     
    142149        I $G(BSDR("ADT"))'?7N.1".".4N Q 1_U_"Appt Date/Time error: "_$G(BSDR("ADT"))
    143150        ;
    144     ; Appt Length check removed in v 1.5
    145     ;
     151        ; Appt Length check removed in v 1.5
     152        ;
    146153        I '$D(^VA(200,+$G(BSDR("USR")),0)) Q 1_U_"User Who Made Appt Error: "_$G(BSDR("USR"))
    147154        ; More verbose error message in v1.5
     
    160167        . . S BSDXERR=BSDXERR_$C(13,10)_"Scheduling GUI clinic: "_BSDXRESNAM ; tell the user of the BSDX clinic
    161168        Q 0
    162     ;
     169        ;
    163170UNMAKE(BSDR) ; Reverse Make - Private $$
    164     ; Only used in Emergiencies where Fileman data filing fails.
    165     ; If previous data exists, which caused an error, it's destroyed.
    166     N BSDXFDA,BSDXIENS
    167         S BSDXIENS=BSDR("ADT")_","_BSDR("PAT")_","
    168         S BSDXFDA(2.98,BSDXIENS,".01")="@"
    169     ;
    170     I '$D(^SC(BSDR("CLN"),"S",BSDR("ADT"),1)) QUIT 0 ; No stuff in HL file
    171     N X S X=0 F  S X=$O(^SC(BSDR("CLN"),"S",BSDR("ADT"),1,X)) Q:'X  Q:+^(X,0)=BSDR("PAT")
    172         ;
    173     I 'X QUIT 0 ; Patient doesn't have appointment
    174     ;
    175     S BSDXIENS=X_","_BSDR("ADT")_","_BSDR("CLN")_","
    176         S BSDXFDA(44.003,BSDXIENS,.01)="@"
    177     N BSDXMSG
    178     D FILE^DIE("","BSDXFDA","BSDXMSG")
    179     I $D(BSDXMSG) S $EC=",U1," ; If we get an error here, we are REALLY out of control
    180     QUIT 0
     171        ; Only used in Emergiencies where Fileman data filing fails.
     172        ; If previous data exists, which caused an error, it's destroyed.
     173        ; NB: ^DIK stops for nobody
     174        ; Input: Same array as $$MAKE
     175        ; Output: Always 0
     176        NEW DIK,DA
     177        S DIK="^DPT("_BSDR("PAT")_",""S"","
     178        S DA(1)=BSDR("PAT"),DA=BSDX("ADT")
     179        D ^DIK
     180        ;
     181        N IEN S IEN=$$SCIEN(BSDR("PAT"),BSDR("CLN"),BSDR("ADT"))
     182        I 'IEN QUIT 0
     183        ;
     184        NEW DIK,DA
     185        S DIK="^SC("_BSDR("CLN")_",""S"","_BSDR("ADT")_",1,"
     186        S DA(2)=BSDR("CLN"),DA(1)=BSDR("ADT"),DA=IEN
     187        D ^DIK
     188        QUIT 0
     189        ;
    181190CHECKIN1(DFN,CLIN,APDATE)       ; Simplified PEP w/ parameters for $$CHECKIN - Checking in
    182191        ; Call like this for DFN 23435 checking in now at Hospital Location 33
Note: See TracChangeset for help on using the changeset viewer.