ASDPC.m

ASDPC ; IHS/ADC/PDW/ENM - principal clinic make appt. ;  [ 01/29/2003  1:20 PM ]

 ;;5.0;IHS SCHEDULING;**8**;MAR 25, 1999

 ;1/28/03 WAR - Patch 8

 ;

 I '$D(DUZ(2)) Q

 NEW SDPC D DT^DICRW

 ;

 S DIC="^SC(",DIC(0)="AEMZQ",DIC("A")="Select PRINCIPAL CLINIC NAME: "

 S DIC("S")="I $P(^(0),""^"",3)=""C"",'$D(^(9,""B"",$I)),$D(^SC(""AIHSPC"",+Y))"

 D ^DIC K DIC I Y<0 Q

 S SDPC=+Y

 ;

EN ;EP; called by SDM with SDPC set

 NEW SDAY,SDX,SDN,SDD,Y,Z,SDSLOT

 S %DT="AE",%DT("A")="Enter EARLIEST POSSIBLE APPT DATE: "

 S %DT("B")="TODAY",X="" D ^%DT S SDAY=Y

 ;

 S %DT="AE",%DT("A")="Enter LATEST POSSIBLE APPT DATE: "

 S %DT("B")="T+15",X="" D ^%DT S SDEND=Y+.2400 W !!

 ;

SC S (SDN,SDCNT)=0 F  S SDN=$O(^SC("AIHSPC",SDPC,SDN)) Q:'SDN  D DAY

 W ! Q

 ;

DAY S SDD=SDAY-.001,Z="",SDSLOT=0

 F  S SDD=$O(^SC(SDN,"ST",SDD)) Q:'SDD  Q:SDD>SDEND  Q:SDSLOT  D

 . S SDX=0

 . F  S SDX=$O(^SC(SDN,"ST",SDD,SDX)) Q:'SDX  Q:+SDSLOT  D

 ..;1/28/03 WAR changed next line from '6' to '5'

 ..; S Z=$E(^SC(SDN,"ST",SDD,SDX),6,$L(^SC(SDN,"ST",SDD,SDX)))

 .. S Z=$E(^SC(SDN,"ST",SDD,SDX),5,$L(^SC(SDN,"ST",SDD,SDX)))

 .. Q:Z["CANCELLED"

 .. I (Z'["|"),(Z'["[") Q

 ..;1/28/03 WAR REM'd the next 5 lines and added the $TR

 ..; I Z["|" S SDSLOT=$P(Z,"|",2,999)  ;1/28/03 WAR REM'd

 ..; I Z'["|" S SDSLOT=$E(Z,6,999)  ;1/28/03 WAR REM'd

 ..; F I="|","[","]","*"," ","0" S SDSLOT=$$STRIP^XLFSTR(SDSLOT,I)

 ..; F I="A","B","C","D","E","F" S SDSLOT=$$STRIP^XLFSTR(SDSLOT,I)

 ..; F I="j","k","l","m","n","o" S SDSLOT=$$STRIP^XLFSTR(SDSLOT,I)

 .. S SDSLOT=$TR(Z,"|[@#]!$* ABCDEFXjklmno",0)  ;1/28/03 WAR added

 .. Q:+SDSLOT<1

 .. S Y=SDD X ^DD("DD")

 .. W !,$P(^SC(SDN,0),U,1),?25,Y,!,^SC(SDN,"ST",SDD,SDX)

 .. S SDCNT=SDCNT+2 I SDCNT>18 D

 ... K DIR S DIR(0)="E",DIR("A")="Press RETURN for more choices"

 ... D ^DIR K DIR S SDCNT=0

 Q

ASDPC     ; IHS/ADC/PDW/ENM - principal clinic make appt. ;  [ 01/29/2003  1:20 PM ]

 +1       ;;5.0;IHS SCHEDULING;**8**;MAR 25, 1999

 +2       ;1/28/03 WAR - Patch 8

 +3       ;

 +4        IF '$DATA(DUZ(2))

               QUIT 

 +5        NEW SDPC

           DO DT^DICRW

 +6       ;

 +7        SET DIC="^SC("

           SET DIC(0)="AEMZQ"

           SET DIC("A")="Select PRINCIPAL CLINIC NAME: "

 +8        SET DIC("S")="I $P(^(0),""^"",3)=""C"",'$D(^(9,""B"",$I)),$D(^SC(""AIHSPC"",+Y))"

 +9        DO ^DIC

           KILL DIC

           IF Y<0

               QUIT 

 +10       SET SDPC=+Y

 +11      ;

EN        ;EP; called by SDM with SDPC set

 +1        NEW SDAY,SDX,SDN,SDD,Y,Z,SDSLOT

 +2        SET %DT="AE"

           SET %DT("A")="Enter EARLIEST POSSIBLE APPT DATE: "

 +3        SET %DT("B")="TODAY"

           SET X=""

           DO ^%DT

           SET SDAY=Y

 +4       ;

 +5        SET %DT="AE"

           SET %DT("A")="Enter LATEST POSSIBLE APPT DATE: "

 +6        SET %DT("B")="T+15"

           SET X=""

           DO ^%DT

           SET SDEND=Y+.2400

           WRITE !!

 +7       ;

SC         SET (SDN,SDCNT)=0

           FOR 

               SET SDN=$ORDER(^SC("AIHSPC",SDPC,SDN))

               IF 'SDN

                   QUIT 

               DO DAY

 +1        WRITE !

           QUIT 

 +2       ;

DAY        SET SDD=SDAY-.001

           SET Z=""

           SET SDSLOT=0

 +1        FOR 

               SET SDD=$ORDER(^SC(SDN,"ST",SDD))

               IF 'SDD

                   QUIT 

               IF SDD>SDEND

                   QUIT 

               IF SDSLOT

                   QUIT 

               Begin DoDot:1

 +2                SET SDX=0

 +3                FOR 

                       SET SDX=$ORDER(^SC(SDN,"ST",SDD,SDX))

                       IF 'SDX

                           QUIT 

                       IF +SDSLOT

                           QUIT 

                       Begin DoDot:2

 +4       ;1/28/03 WAR changed next line from '6' to '5'

 +5       ; S Z=$E(^SC(SDN,"ST",SDD,SDX),6,$L(^SC(SDN,"ST",SDD,SDX)))

 +6                        SET Z=$EXTRACT(^SC(SDN,"ST",SDD,SDX),5,$LENGTH(^SC(SDN,"ST",SDD,SDX)))

 +7                        IF Z["CANCELLED"

                               QUIT 

 +8                        IF (Z'["|")

                               IF (Z'["[")

                                   QUIT 

 +9       ;1/28/03 WAR REM'd the next 5 lines and added the $TR

 +10      ; I Z["|" S SDSLOT=$P(Z,"|",2,999)  ;1/28/03 WAR REM'd

 +11      ; I Z'["|" S SDSLOT=$E(Z,6,999)  ;1/28/03 WAR REM'd

 +12      ; F I="|","[","]","*"," ","0" S SDSLOT=$$STRIP^XLFSTR(SDSLOT,I)

 +13      ; F I="A","B","C","D","E","F" S SDSLOT=$$STRIP^XLFSTR(SDSLOT,I)

 +14      ; F I="j","k","l","m","n","o" S SDSLOT=$$STRIP^XLFSTR(SDSLOT,I)

 +15      ;1/28/03 WAR added

                           SET SDSLOT=$TRANSLATE(Z,"|[@#]!$* ABCDEFXjklmno",0)

 +16                       IF +SDSLOT<1

                               QUIT 

 +17                       SET Y=SDD

                           XECUTE ^DD("DD")

 +18                       WRITE !,$PIECE(^SC(SDN,0),U,1),?25,Y,!,^SC(SDN,"ST",SDD,SDX)

 +19                       SET SDCNT=SDCNT+2

                           IF SDCNT>18

                               Begin DoDot:3

 +20                               KILL DIR

                                   SET DIR(0)="E"

                                   SET DIR("A")="Press RETURN for more choices"

 +21                               DO ^DIR

                                   KILL DIR

                                   SET SDCNT=0

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +22       QUIT