Changeset 1467 for Scheduling


Ignore:
Timestamp:
Jul 5, 2012, 7:42:34 PM (12 years ago)
Author:
Sam Habiel
Message:

BSDX25 refactoring is done; moved PIMS availability change logic from BSDX07 and BSDX08 to BSDXAPI*.m. Calling these has moved from BSDX07 and BSDX08 to 1926MAKE and 1926CANCELBSDXAPI.

Location:
Scheduling/trunk/m
Files:
6 edited

Legend:

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

    r1454 r1467  
    1 BSDX07  ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS  ; 6/21/12 3:54pm
     1BSDX07  ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS  ; 7/5/12 12:57pm
    22        ;;1.7T1;BSDX;;Aug 31, 2011;Build 18
    33        ; Licensed under LGPL
     
    1212        ; v1.6 Apr 11 2011 - Support for Scheduling Radiology Exams...
    1313        ; v1.7 Jun 20 2012 - Refactoring to remove transactions - many changes
     14        ;                  - AVUPDT moved to AVUPDTMK in BSDXAPI1
    1415        ;
    1516        ; Error Reference:
     
    5859        ;
    5960        ; NB: Specifying BSDXLEN and BSDXEND is redundant. For future programmers
    60         ; to sort out
     61        ; to sort out. Needs changes on client.
    6162        ;
    6263        ;Test lines:
     
    162163        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
    163164        . S BSDXERR=$$MAKE^BSDXAPI(.BSDXC)
    164         . Q:BSDXERR
    165         . D AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN) ; Update RPMS Clinic availability
    166165        ;
    167166        ;Return Recordset
     
    244243        ; Appointment ID to remove from ^BSDXAPPT
    245244        ; BSDXC array (see array format in $$MAKE^BSDXAPI)
    246         ; NB: I am not sure whether I want to do $G to protect??
     245        ; NB: I am not sure whether I want to do $G to protect against undefs?
    247246        ; I send the variables to this EP from the Symbol Table in ETRAP
    248247        D BSDXDEL^BSDX07(BSDXAPPTID)
     
    276275        Q:$Q 1_U_"Mumps Error" Q
    277276        ;
    278 DAY     ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
    279         ;
    280 DOW     S %=$E(X,1,3),Y=$E(X,4,5),Y=Y>2&'(%#4)+$E("144025036146",Y)
    281         F %=%:-1:281 S Y=%#4=1+1+Y
    282         S Y=$E(X,6,7)+Y#7
    283         Q
    284         ;
    285 AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)         ;Update RPMS Clinic availability
    286         ;SEE SDM1
    287         N Y,DFN
    288         N SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG
    289         N X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I
    290         S Y=BSDXSCD,DFN=BSDXPATID
    291         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
    292         ;Determine maximum days for scheduling
    293         S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
    294         S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
    295         S SDDATE=BSDXSTART
    296         S SDSDATE=SDDATE,SDDATE=SDDATE\1
    297 1 ;L  Q:$D(SDXXX)  S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0  S SC=+SC
    298         Q:$D(SDXXX)  S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0  S SC=+SC
    299         S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)
    300         S X2=SDEDT D C^%DTC S SDEDT=X
    301         S Y=BSDXSTART
    302 EN1     S (X,SD)=Y,SM=0 D DOW
    303 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,".")
    304         S S=BSDXLEN
    305         ;Check if BSDXLEN evenly divisible by appointment length
    306         S RPMSL=$P(SL,U)
    307         I BSDXLEN<RPMSL S BSDXLEN=RPMSL
    308         I BSDXLEN#RPMSL'=0 D
    309         . S BSDXINC=BSDXLEN\RPMSL
    310         . S BSDXINC=BSDXINC+1
    311         . S BSDXLEN=RPMSL*BSDXINC
    312         S SL=S_U_$P(SL,U,2,99)
    313 SC      S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) Q:SDLOCK>9
    314         L +^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC
    315         S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1)
    316         S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
    317         I (I<1!'$F(S,"["))&(S'["CAN") L -^SC(SC,"ST",$P(SD,"."),1) Q
    318         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
    319         ;
    320 SP      I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP
    321         S SDNOT=1
    322         S ABORT=0
    323         F I=ST+ST:SDDIF:SS-SDDIF D  Q:ABORT
    324         . S ST=$E(S,I+1) S:ST="" ST=" "
    325         . S Y=$E(STR,$F(STR,ST)-2)
    326         . I S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))) S ABORT=1 Q
    327         . I Y="" S ABORT=1 Q
    328         . 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
    329         . Q
    330         S ^SC(SC,"ST",$P(SD,"."),1)=S
    331         L -^SC(SC,"ST",$P(SD,"."),1)
    332         Q
  • Scheduling/trunk/m/BSDX08.m

    r1461 r1467  
    1 BSDX08  ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 6/26/12 10:49am
     1BSDX08  ; VW/UJO/SMH - WINDOWS SCHEDULING RPCS ; 7/5/12 12:39pm
    22        ;;1.7T1;BSDX;;Aug 31, 2011;Build 18
    33        ;
     
    1616        ; 3120625 VEN/SMH v1.7
    1717        ;  - Transactions removed. Code refactored to work w/o txns.
     18        ;  - Moved AVUPDT to AVUPDTCN in BSDXAPI1. BSDXAPI takes care of calling
     19        ;    that.
    1820        ;
    1921        ; Error Reference:
     
    128130        ; If error happens, must rollback ^BSDXAPPT
    129131        I BSDXLOC D  QUIT:BSDXERR
    130         . N BSDXLEN S BSDXLEN=$$APPLEN^BSDXAPI(BSDXPATID,BSDXLOC,BSDXSTART) ; appt length
    131132        . S BSDXERR=$$CANCEL^BSDXAPI(.BSDXC) ; Cancel through BSDXAPI
    132133        . ; Rollback BSDXAPPT if error occurs
    133         . ; TODO: If an M error occurs in BSDXAPI, ETRAP gets called, ^BSDXTMP is
    134         . ;       populated, then the output of $$CANCEL is the output of ETRAP.
    135         . ;       Then, we see that BSDXERR is true, and we do another write,
    136         . ;       which deletes the information we had in ^BSDXTMP. What to do???
    137134        . I BSDXERR D ERR(BSDXI,"-9^BSDX08: BSDXAPI returned an error: "_$P(BSDXERR,U,2)),ROLLBACK(BSDXAPTID)  QUIT
    138         . ;
    139         . ; Update Legacy PIMS clinic Availability ; no failure expected here.
    140         . D AVUPDT(BSDXLOC,BSDXSTART,BSDXLEN)
    141         ;
    142135        ;
    143136        L -^BSDXAPPT(BSDXAPTID)
     
    146139        S BSDXI=BSDXI+1
    147140        S ^BSDXTMP($J,BSDXI)=$C(31)
    148         Q
    149         ;
    150 AVUPDT(BSDXSCD,BSDXSTART,BSDXLEN)       ;Update Legacy PIMS Clinic availability
    151         ;See SDCNP0
    152         N SD,S  ; Start Date
    153         S (SD,S)=BSDXSTART
    154         N I ; Clinic IEN in 44
    155         S I=BSDXSCD
    156         ; if day has no schedule in legacy PIMS, forget about this update.
    157         Q:'$D(^SC(I,"ST",SD\1,1))
    158         N SL ; Clinic characteristics node (length of appt, when appts start etc)
    159         S SL=^SC(I,"SL")
    160         N X ; Hour Clinic Display Begins
    161         S X=$P(SL,U,3)
    162         N STARTDAY ; When does the day start?
    163         S STARTDAY=$S($L(X):X,1:8) ; If defined, use it; otherwise, 8am
    164         N SB ; ?? Who knows? Day Start - 1 divided by 100.
    165         S SB=STARTDAY-1/100
    166         S X=$P(SL,U,6) ; Now X is Display increments per hour
    167         N HSI ; Slots per hour, try 1
    168         S HSI=$S(X:X,1:4) ; if defined, use it; otherwise, 4
    169         N SI ; Slots per hour, try 2
    170         S SI=$S(X="":4,X<3:4,X:X,1:4) ; If slots "", or less than 3, then 4
    171         N STR ; ??
    172         S STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
    173         N SDDIF ; Slots per hour diff??
    174         S SDDIF=$S(HSI<3:8/HSI,1:2)
    175         S SL=BSDXLEN ; Dammit, reusing variable; SL now Appt Length from GUI
    176         S S=^SC(I,"ST",SD\1,1) ; reusing var again; S now Day Pattern from PIMS
    177         N Y ; Hours since start of Date
    178         S Y=SD#1-SB*100 ;SD#1=FM Time portion; -SB minus start of day; conv to hrs
    179         N ST  ; ??
    180         ; Y#1 -> Minutes; *SI -> * Slots per hour; \.6 trunc min to hour
    181         ; Y\1 -> Hours since start of day; * SI: * slots
    182         S ST=Y#1*SI\.6+(Y\1*SI)
    183         N SS ; how many slots are supposed to be taken by appointment
    184         S SS=SL*HSI/60 ; (nb: try SL: 30 min; HSI: 4 slots)
    185         N I
    186         I Y'<1 D  ; If Hours since start of Date is greater than 1
    187         . ; loop through pattern. Tired of documenting.
    188         . F I=ST+ST:SDDIF D  Q:Y=""  Q:SS'>0
    189         . . S Y=$E(STR,$F(STR,$E(S,I+1))) Q:Y=""
    190         . . S S=$E(S,1,I)_Y_$E(S,I+2,999)
    191         . . S SS=SS-1
    192         . . Q:SS'>0
    193         S ^SC(BSDXSCD,"ST",SD\1,1)=S  ; new pattern; global set
    194141        Q
    195142        ;
     
    254201        ;
    255202ERR(BSDXI,BSDXERR)      ;Error processing
     203        ; If last line is $C(31), we are done. No more errors to send to client.
     204        I ^BSDXTMP($J,$O(^BSDXTMP($J," "),-1))=$C(31) QUIT
    256205        S BSDXI=BSDXI+1
    257206        S BSDXERR=$TR(BSDXERR,"^","~")
     
    265214        N $ET S $ET="D ^%ZTER HALT"  ; Emergency Error Trap
    266215        D ^%ZTER
    267         S $EC=""  ; Clear Error
    268216        ; Roll back BSDXAPPT;
    269         ; TODO: What if a Mumps error happens in fileman in BSDXAPI? The Scheduling files can potentially be out of sync
     217        ; NB: What if a Mumps error happens inside fileman in BSDXAPI?
     218        ; I have decided the M errors are out of scope for me to handle.
    270219        D:$G(BSDXAPTID) ROLLBACK(BSDXAPTID)
    271220        ; Log error message and send to client
  • Scheduling/trunk/m/BSDX25.m

    r1466 r1467  
    1 BSDX25  ; VEN/SMH - WINDOWS SCHEDULING RPCS ; 7/3/12 12:27pm
     1BSDX25  ; VEN/SMH - WINDOWS SCHEDULING RPCS ; 7/5/12 11:55am
    22        ;;1.7T1;BSDX;;Aug 31, 2011;Build 18
    33        ; Licensed under LGPL
     
    55        ; Change Log:
    66        ; 3110106: SMH -> Changed Check-in EP - Removed unused paramters. Will change C#
     7        ; 3120630: VEN/SMH -> Extensive Refactoring to remove transactions.
     8        ;                  -> Functionality still the same.
     9        ;                  -> Unit Tests in UT25^BSDXUT2
    710        ;
    811        ;
     
    160163        I '$D(^BSDXAPPT(BSDXAPPTID,0)) D ERR("-2~Invalid Appointment ID") QUIT
    161164        ;
    162         ; Remove checkin from BSDX APPOINTMENT entry
    163         N BSDXERR S BSDXERR=$$BSDXCHK(BSDXAPPTID,"@")
    164         I BSDXERR D ERR("-6~Cannot file data in $$BSDXCHK") QUIT
    165         ;
    166         ; Now, remove checkin from PIMS files 2/44
     165        ; Get appointment Data
    167166        N BSDXNOD S BSDXNOD=^BSDXAPPT(BSDXAPPTID,0)
    168167        N BSDXPATID S BSDXPATID=$P(BSDXNOD,U,5) ; DFN
    169168        N BSDXSTART S BSDXSTART=$P(BSDXNOD,U) ; Start Date
    170         N BSDXSC1 S BSDXSC1=$P(BSDXNOD,U,7) ; Resource ID
     169        N BSDXRESID S BSDXRESID=$P(BSDXNOD,U,7) ; Resource ID
    171170        ;
    172171        ; If the resource doesn't exist, error out. DB is corrupt.
    173         I 'BSDXSC1 D ERR("-3~DB has corruption. Call Tech Support.") QUIT
    174         I '$D(^BSDXRES(BSDXSC1,0)) D ERR("-4~DB has corruption. Call Tech Support.") QUIT
    175         ;
    176         N BSDXNOD S BSDXNOD=^BSDXRES(BSDXSC1,0) ; Resource 0 node
    177         S BSDXSC1=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION
    178         ;
    179         N BSDXZ ; Scratch variable to hold error message
    180         I BSDXSC1]"",$D(^SC(BSDXSC1,0)) S BSDXZ=$$RMCI^BSDXAPI1(BSDXPATID,BSDXSC1,BSDXSTART)
    181         I +$G(BSDXZ) D ERR("-5~"_$P(BSDXZ,U,2)) QUIT
     172        I 'BSDXRESID D ERR("-3~DB has corruption. Call Tech Support.") QUIT
     173        I '$D(^BSDXRES(BSDXRESID,0)) D ERR("-4~DB has corruption. Call Tech Support.") QUIT
     174        ;
     175        ; Get HL Data
     176        N BSDXNOD S BSDXNOD=^BSDXRES(BSDXRESID,0) ; Resource 0 node
     177        N BSDXSC1 S BSDXSC1=$P(BSDXNOD,U,4) ;HOSPITAL LOCATION IEN
     178        I BSDXSC1,'$D(^SC(BSDXSC1,0)) S BSDXSC1="" ; Zero out if HL doesn't exist
     179        ;
     180        ; Is it okay to remove check-in from PIMS?
     181        N BSDXERR S BSDXERR=0 ; Scratch variable
     182        ; $$RMCICK = Remove Check-in Check
     183        I BSDXSC1 S BSDXERR=$$RMCICK^BSDXAPI1(BSDXPATID,BSDXSC1,BSDXSTART)
     184        I BSDXERR D ERR("-5~"_$P(BSDXERR,U,2)) QUIT
     185        ;
     186        ; For possible rollback, get old check-in date (internal value)
     187        N BSDXCDT S BSDXCDT=$$GET1^DIQ(9002018.4,BSDXAPPTID_",",.03,"I")
     188        ;
     189        ; Remove checkin from BSDX APPOINTMENT entry
     190        ; No need to rollback here on failure.
     191        N BSDXERR S BSDXERR=$$BSDXCHK(BSDXAPPTID,"@")
     192        I BSDXERR D ERR("-6~Cannot file data in $$BSDXCHK") QUIT
     193        ;
     194        ; Now, remove checkin from PIMS files 2/44
     195        ; Restore BSDXCDT into ^BSDXAPPT if we fail.
     196        N BSDXERR S BSDXERR=0 ; Scratch variable to hold error message
     197        I BSDXSC1 S BSDXERR=$$RMCI^BSDXAPI1(BSDXPATID,BSDXSC1,BSDXSTART)
     198        I BSDXERR D  QUIT
     199        . N % S %=$$BSDXCHK(BSDXAPPTID,BSDXCDT) ; No error checking here.
     200        . D ERR("-5~"_$P(BSDXERR,U,2)) ; Send error message to client
    182201        ;
    183202        ; Return ADO recordset
     
    238257        ; Individual portions of this routine may choose to do rolling back
    239258        ; of their own (e.g. a failed call to BSDXAPI causes rollback to occur
    240         ; in CHECKIN)
     259        ; in CHECKIN and RMCI)
    241260        ;
    242261        ; Log error message and send to client
  • Scheduling/trunk/m/BSDXAPI.m

    r1466 r1467  
    1 BSDXAPI ; IHS/ANMC/LJF & VW/SMH - SCHEDULING APIs ; 7/3/12 12:30pm
     1BSDXAPI ; IHS/LJF,HMW,MAW & VEN/SMH - SCHEDULING APIs ; 7/5/12 12:52pm
    22        ;;1.7T1;BSDX;;Aug 31, 2011;Build 18
    33        ; Licensed under LGPL 
     
    110110        ;Q:$G(BSDXSIMERR5) 1_U_$NA(BSDXSIMERR5) ; Unit Test line
    111111        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"))
    112115        ;
    113116        ; call event driver
     
    327330        ; get user who made appt and date appt made from ^SC
    328331        ;    because data in ^SC will be deleted
     332        ; Appointment Length: ditto
    329333        NEW USER,DATE
    330334        S USER=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,6)
    331335        S DATE=$P($G(^SC(SDCL,"S",SDT,1,IEN,0)),U,7)
     336        N BSDXLEN S BSDXLEN=$$APPLEN(DFN,SDCL,SDT) ; appt length
    332337        ;
    333338        ; update file 2 info --old code; keep for reference
     
    350355        I $D(BSDXERR) Q 1_U_"Cannot cancel appointment in File 2"
    351356        ; Failure point 1: If we fail here, nothing has happened yet.
    352         ; No rollback needed in ^BSDXAPPT
    353357        ;
    354358        ; delete data in ^SC -- this does not (typically) fail. Fileman won't stop
     
    359363        ; Failure point 2: not expected to happen here
    360364        ;
     365        ; Update PIMS availability -- this doesn't fail. Global gets/sets only.
     366        D AVUPDTCN^BSDXAPI1(SDCL,SDT,BSDXLEN)
     367        ;
    361368        ; call event driver -- point of no return
    362369        D CANCEL^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDMODE,SDCPHDL)
     370        ;
    363371        Q 0
    364372        ;
  • Scheduling/trunk/m/BSDXAPI1.m

    r1466 r1467  
    1 BSDXAPI1 ; VEN/SMH - SCHEDULING APIs - Continued!!! ; 7/3/12 12:37pm
     1BSDXAPI1 ; VEN/SMH - SCHEDULING APIs - Continued!!! ; 7/5/12 12:55pm
    22        ;;1.7T1;BSDX;;Aug 31, 2011;Build 18
    33        ; Licensed under LGPL 
     
    4242        ; CANCELCK exists for the same purpose.
    4343        ; CHECKINK ditto
    44         ; New API: $$NOWSHOW^BSDXAPI1 for no-showing patients
     44        ; New API: $$NOSHOW^BSDXAPI1 for no-showing patients
    4545        ; Moved RMCI from BSDXAPI to BSDXAPI1 because BSDXAPI1 is getting larger
    4646        ;  than 20000 characters.
     47        ; Added RMCICK (Remove check-in check)
     48        ; Moved Availability update EPs in BSDX07 and BSDX08 b/c they really
     49        ; belong to PIMS, not to the Scheduling GUI. $$MAKE and $$CANCEL now
     50        ; call the EPs here.
    4751        ;
    4852NOSHOW(PAT,CLINIC,DATE,NSFLAG) ; $$ PEP; No-show Patient at appt date (new in v1.7)
     
    125129        D BEFORE^SDAMEVT(.SDATA,DFN,SDT,SDCL,SDDA,SDCIHDL)
    126130        ;
     131        ; M Error Test - Simulate behavior when an M error occurs
     132        I $G(BSDXDIE2) N X S X=1/0
     133        ;
     134        ; Simulate a failure to file the data in Fileman
     135        I $D(BSDXSIMERR3) Q 1_U_"Simulated Error"
     136        ;
    127137        ; remove check-in using filer.
    128138        N BSDXIENS S BSDXIENS=SDDA_","_DATE_","_CLINIC_","
     
    150160        ; Output: 0 if okay or 1 if error
    151161        ;
     162        ; Error for Unit Tests
     163        I $G(BSDXSIMERR2) Q 1_U_"Simulated Error"
     164        ;
    152165        ; Get appointment IEN in ^SC(DA(2),"S",DA(1),1,
    153166        N SCIEN S SCIEN=$$SCIEN^BSDXAPI(PAT,CLINIC,DATE)
    154167        ;
    155         ; If not there, it has been cancelled.
     168        ; If not there, it has been cancelled. Okay to Remove Check-in.
    156169        I 'SCIEN QUIT 0
    157170        ;
     
    182195        QUIT 0
    183196        ;
     197AVUPDTCN(BSDXSCD,BSDXSTART,BSDXLEN)     ;Update PIMS Clinic availability for cancel
     198        ; NB: VEN/SMH: This code has never been tested. It's here for its
     199        ; presumptive function, but I don't know whether it works accurately!
     200        ;See SDCNP0
     201        N SD,S  ; Start Date
     202        S (SD,S)=BSDXSTART
     203        N I ; Clinic IEN in 44
     204        S I=BSDXSCD
     205        ; if day has no schedule in legacy PIMS, forget about this update.
     206        Q:'$D(^SC(I,"ST",SD\1,1))
     207        N SL ; Clinic characteristics node (length of appt, when appts start etc)
     208        S SL=^SC(I,"SL")
     209        N X ; Hour Clinic Display Begins
     210        S X=$P(SL,U,3)
     211        N STARTDAY ; When does the day start?
     212        S STARTDAY=$S($L(X):X,1:8) ; If defined, use it; otherwise, 8am
     213        N SB ; ?? Who knows? Day Start - 1 divided by 100.
     214        S SB=STARTDAY-1/100
     215        S X=$P(SL,U,6) ; Now X is Display increments per hour
     216        N HSI ; Slots per hour, try 1
     217        S HSI=$S(X:X,1:4) ; if defined, use it; otherwise, 4
     218        N SI ; Slots per hour, try 2
     219        S SI=$S(X="":4,X<3:4,X:X,1:4) ; If slots "", or less than 3, then 4
     220        N STR ; ??
     221        S STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
     222        N SDDIF ; Slots per hour diff??
     223        S SDDIF=$S(HSI<3:8/HSI,1:2)
     224        S SL=BSDXLEN ; Dammit, reusing variable; SL now Appt Length from GUI
     225        S S=^SC(I,"ST",SD\1,1) ; reusing var again; S now Day Pattern from PIMS
     226        N Y ; Hours since start of Date
     227        S Y=SD#1-SB*100 ;SD#1=FM Time portion; -SB minus start of day; conv to hrs
     228        N ST  ; ??
     229        ; Y#1 -> Minutes; *SI -> * Slots per hour; \.6 trunc min to hour
     230        ; Y\1 -> Hours since start of day; * SI: * slots
     231        S ST=Y#1*SI\.6+(Y\1*SI)
     232        N SS ; how many slots are supposed to be taken by appointment
     233        S SS=SL*HSI/60 ; (nb: try SL: 30 min; HSI: 4 slots)
     234        N I
     235        I Y'<1 D  ; If Hours since start of Date is greater than 1
     236        . ; loop through pattern. Tired of documenting.
     237        . F I=ST+ST:SDDIF D  Q:Y=""  Q:SS'>0
     238        . . S Y=$E(STR,$F(STR,$E(S,I+1))) Q:Y=""
     239        . . S S=$E(S,1,I)_Y_$E(S,I+2,999)
     240        . . S SS=SS-1
     241        . . Q:SS'>0
     242        S ^SC(BSDXSCD,"ST",SD\1,1)=S  ; new pattern; global set
     243        Q
     244        ;
     245AVUPDTMK(BSDXSCD,BSDXSTART,BSDXLEN) ; Update RPMS Clinic availability for Make
     246        ;SEE SDM1
     247        N Y,DFN
     248        N SL,STARTDAY,X,SC,SB,HSI,SI,STR,SDDIF,SDMAX,SDDATE,SDDMAX,SDSDATE,CCXN,MXOK,COV,SDPROG
     249        N X1,SDEDT,X2,SD,SM,SS,S,SDLOCK,ST,I
     250        S Y=BSDXSCD,DFN=BSDXPATID
     251        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
     252        ;Determine maximum days for scheduling
     253        S SDMAX(1)=$P($G(^SC(+SC,"SDP")),U,2) S:'SDMAX(1) SDMAX(1)=365
     254        S (SDMAX,SDDMAX)=$$FMADD^XLFDT(DT,SDMAX(1))
     255        S SDDATE=BSDXSTART
     256        S SDSDATE=SDDATE,SDDATE=SDDATE\1
     2571 ;L  Q:$D(SDXXX)  S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0  S SC=+SC
     258        Q:$D(SDXXX)  S CCXN=0 K MXOK,COV,SDPROT Q:DFN<0  S SC=+SC
     259        S X1=DT,SDEDT=365 S:$D(^SC(SC,"SDP")) SDEDT=$P(^SC(SC,"SDP"),"^",2)
     260        S X2=SDEDT D C^%DTC S SDEDT=X
     261        S Y=BSDXSTART
     262EN1     S (X,SD)=Y,SM=0 D DOW
     263S       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,".")
     264        S S=BSDXLEN
     265        ;Check if BSDXLEN evenly divisible by appointment length
     266        S RPMSL=$P(SL,U)
     267        I BSDXLEN<RPMSL S BSDXLEN=RPMSL
     268        I BSDXLEN#RPMSL'=0 D
     269        . S BSDXINC=BSDXLEN\RPMSL
     270        . S BSDXINC=BSDXINC+1
     271        . S BSDXLEN=RPMSL*BSDXINC
     272        S SL=S_U_$P(SL,U,2,99)
     273SC      S SDLOCK=$S('$D(SDLOCK):1,1:SDLOCK+1) Q:SDLOCK>9
     274        L +^SC(SC,"ST",$P(SD,"."),1):5 G:'$T SC
     275        S SDLOCK=0,S=^SC(SC,"ST",$P(SD,"."),1)
     276        S I=SD#1-SB*100,ST=I#1*SI\.6+($P(I,".")*SI),SS=SL*HSI/60*SDDIF+ST+ST
     277        I (I<1!'$F(S,"["))&(S'["CAN") L -^SC(SC,"ST",$P(SD,"."),1) Q
     278        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
     279        ;
     280SP      I ST+ST>$L(S),$L(S)<80 S S=S_" " G SP
     281        S SDNOT=1
     282        S ABORT=0
     283        F I=ST+ST:SDDIF:SS-SDDIF D  Q:ABORT
     284        . S ST=$E(S,I+1) S:ST="" ST=" "
     285        . S Y=$E(STR,$F(STR,ST)-2)
     286        . I S["CAN"!(ST="X"&($D(^SC(+SC,"ST",$P(SD,"."),"CAN")))) S ABORT=1 Q
     287        . I Y="" S ABORT=1 Q
     288        . 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
     289        . Q
     290        S ^SC(SC,"ST",$P(SD,"."),1)=S
     291        L -^SC(SC,"ST",$P(SD,"."),1)
     292        Q
     293DAY     ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR
     294        ;
     295DOW     S %=$E(X,1,3),Y=$E(X,4,5),Y=Y>2&'(%#4)+$E("144025036146",Y)
     296        F %=%:-1:281 S Y=%#4=1+1+Y
     297        S Y=$E(X,6,7)+Y#7
     298        Q
     299        ;
  • Scheduling/trunk/m/BSDXUT2.m

    r1466 r1467  
    1 BSDXUT2 ; VEN/SMH - Unit Tests for Scheduling GUI - cont. ; 7/3/12 12:03pm
     1BSDXUT2 ; VEN/SMH - Unit Tests for Scheduling GUI - cont. ; 7/5/12 11:39am
    22        ;;1.7T1;BSDX;;Aug 31, 2011;Build 18
    33        ;
     
    6565        IF +^BSDXTMP($J,1)'=-100 WRITE "ERROR IN Etest 9",!
    6666        K BSDXDIE2
     67        ; M Error in $$RMCI^BSDXAPI1
     68        N BSDXDIE2 S BSDXDIE2=1
     69        D RMCI^BSDX25(.ZZZ,APPTID)
     70        IF +^BSDXTMP($J,1)'=-100 WRITE "ERROR IN Etest 13",!
     71        K BSDXDIE2
    6772        ;
    6873        ; Get start and end times
     
    100105        IF $P(^BSDXAPPT(APPTID,0),U,3) WRITE "ERROR IN CHECKIN 115",!
    101106        IF +$G(^SC(HL,"S",APPTTIME,1,1,"C")) WRITE "ERROR IN CHECKIN 116",!
     107        K BSDXSIMERR3
     108        ;
     109        ; Check-in for real for the subsequent tests
     110        D CHECKIN^BSDX25(.ZZZ,APPTID,$$NOW^XLFDT()) ; Check-in first!
     111        IF '$P(^BSDXAPPT(APPTID,0),U,3) WRITE "ERROR IN CHECKIN 1110",!
     112        IF '+$G(^SC(HL,"S",APPTTIME,1,1,"C")) WRITE "ERROR IN RMCI 1120",!
     113        ;
     114        ; Simulated Error in $$BSDXCHK^BSDX25; This time for remove check-in
     115        N BSDXSIMERR1 S BSDXSIMERR1=1
     116        D RMCI^BSDX25(.ZZZ,APPTID)
     117        IF +^BSDXTMP($J,1)'=-6 WRITE "ERROR in Etest 14",!
     118        IF '$P(^BSDXAPPT(APPTID,0),U,3) WRITE "ERROR IN RMCI 111",!
     119        IF '+$G(^SC(HL,"S",APPTTIME,1,1,"C")) WRITE "ERROR IN RMCI 112",!
     120        K BSDXSIMERR1
     121        ;
     122        ; Simulated Error in $$RMCICK^BSDXAPI1
     123        N BSDXSIMERR2 S BSDXSIMERR2=1
     124        D RMCI^BSDX25(.ZZZ,APPTID)
     125        IF +^BSDXTMP($J,1)'=-5 WRITE "ERROR in Etest 15",!
     126        IF '$P(^BSDXAPPT(APPTID,0),U,3) WRITE "ERROR IN RMCI 113",!
     127        IF '+$G(^SC(HL,"S",APPTTIME,1,1,"C")) WRITE "ERROR IN RMCI 114",!
     128        K BSDXSIMERR2
     129        ;
     130        ; Simulated Error in $$RMCI^BSDXAPI1
     131        N BSDXSIMERR3 S BSDXSIMERR3=1
     132        D RMCI^BSDX25(.ZZZ,APPTID)
     133        IF +^BSDXTMP($J,1)'=-5 WRITE "ERROR in Etest 16",!
     134        IF '$P(^BSDXAPPT(APPTID,0),U,3) WRITE "ERROR IN RMCI 115",!
     135        IF '+$G(^SC(HL,"S",APPTTIME,1,1,"C")) WRITE "ERROR IN RMCI 116",!
    102136        K BSDXSIMERR3
    103137        ;
Note: See TracChangeset for help on using the changeset viewer.