BSDMON.m

BSDMON ; IHS/ANMC/LJF - MONTH AT A GLANCE OPTION ;  [ 01/02/2004  10:48 AM ]

 ;;5.3;PIMS;;APR 26, 2002

 ;

 S:'$D(SDMM) SDMM=0

EN1 ; ask clinic and set variables for call to SDM0

 W !! D I^SDUTL

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

 S DIC("S")="I $P(^(0),U,3)=""C"""

 S DIC("W")=$$INACTMSG^BSDU

 D ^DIC K DIC G:Y<0 END

 K SDAPTYP,SDIN,SDRE,SDXXX

 I $D(^SC(+Y,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),U,2)

 K SDINA I $D(SDIN),SDIN S SDINA=SDIN K SDIN

 I $D(SD),$D(SC),+Y'=+SC K SD

 S SL=$G(^SC(+Y,"SL")),X=$P(SL,U,3),STARTDAY=$S(X:X,1:8),SC=Y

 S SB=STARTDAY-1/100,X=$P(SL,U,6),HSI=$S(X=1:X,X:X,1:4)

 S SI=$S(X="":4,X<3:4,X:X,1:4)

 S STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"

 S SDDIF=$S(HSI<3:8/HSI,1:2) K Y

 D CS^SDM1A S SDW="",WY="Y" ;checks clinic code

 ;

 I $D(^SC("AIHSPC",+SC)) D  G EN1

 . NEW DIR

 . W !!,*7," This is a Principal Clinic!",!

 . K DIR S DIR(0)="NO^1:2",DIR("B")=2

 . S DIR("A",1)=" 1  Display availability of just this clinic"

 . S DIR("A",2)=" 2  Display first available for clinics under this grouping"

 . S DIR("A")="Select 1 or 2" D ^DIR W !

 . I Y=1 S DFN=-1 D ^SDM0 Q

 . I Y=2 S SDPC=+SC D EN^BSDPC K SDPC

 ;

 ; -- call display code then return to ask for another clinic

 S DFN=-1 D ^SDM0 G EN1

 ;

 ;

END D KVAR^VADPT K SDAPTYP,SDSC,%,%DT,ASKC,COV,DA,DIC,DIE,DP,DR

 K HEY,HSI,HY,J,SB,SC,SDDIF,SDJ,SDLN,SD17,SDMAX,SDU,SDYC,SI,SL

 K SSC,STARTDAY,STR,SDZPR,WY,X,XX,Y,S,SD,SDAP16,SDEDT,SDTY,SM

 K SS,ST,ARG,CCX,CCXN,HX,I,PXR,SDINA,SDW,COLLAT,SDDIS,SDMM,SDMLT1

 K SDAV,SDHX,SDSOH,SDT

 Q

BSDMON    ; IHS/ANMC/LJF - MONTH AT A GLANCE OPTION ;  [ 01/02/2004  10:48 AM ]

 +1       ;;5.3;PIMS;;APR 26, 2002

 +2       ;

 +3        IF '$DATA(SDMM)

               SET SDMM=0

EN1       ; ask clinic and set variables for call to SDM0

 +1        WRITE !!

           DO I^SDUTL

 +2        SET DIC="^SC("

           SET DIC(0)="AEMZQ"

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

 +3        SET DIC("S")="I $P(^(0),U,3)=""C"""

 +4        SET DIC("W")=$$INACTMSG^BSDU

 +5        DO ^DIC

           KILL DIC

           IF Y<0

               GOTO END

 +6        KILL SDAPTYP,SDIN,SDRE,SDXXX

 +7        IF $DATA(^SC(+Y,"I"))

               SET SDIN=+^("I")

               SET SDRE=+$PIECE(^("I"),U,2)

 +8        KILL SDINA

           IF $DATA(SDIN)

               IF SDIN

                   SET SDINA=SDIN

                   KILL SDIN

 +9        IF $DATA(SD)

               IF $DATA(SC)

                   IF +Y'=+SC

                       KILL SD

 +10       SET SL=$GET(^SC(+Y,"SL"))

           SET X=$PIECE(SL,U,3)

           SET STARTDAY=$SELECT(X:X,1:8)

           SET SC=Y

 +11       SET SB=STARTDAY-1/100

           SET X=$PIECE(SL,U,6)

           SET HSI=$SELECT(X=1:X,X:X,1:4)

 +12       SET SI=$SELECT(X="":4,X<3:4,X:X,1:4)

 +13       SET STR="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"

 +14       SET SDDIF=$SELECT(HSI<3:8/HSI,1:2)

           KILL Y

 +15      ;checks clinic code

           DO CS^SDM1A

           SET SDW=""

           SET WY="Y"

 +16      ;

 +17       IF $DATA(^SC("AIHSPC",+SC))

               Begin DoDot:1

 +18               NEW DIR

 +19               WRITE !!,*7," This is a Principal Clinic!",!

 +20               KILL DIR

                   SET DIR(0)="NO^1:2"

                   SET DIR("B")=2

 +21               SET DIR("A",1)=" 1  Display availability of just this clinic"

 +22               SET DIR("A",2)=" 2  Display first available for clinics under this grouping"

 +23               SET DIR("A")="Select 1 or 2"

                   DO ^DIR

                   WRITE !

 +24               IF Y=1

                       SET DFN=-1

                       DO ^SDM0

                       QUIT 

 +25               IF Y=2

                       SET SDPC=+SC

                       DO EN^BSDPC

                       KILL SDPC

               End DoDot:1

               GOTO EN1

 +26      ;

 +27      ; -- call display code then return to ask for another clinic

 +28       SET DFN=-1

           DO ^SDM0

           GOTO EN1

 +29      ;

 +30      ;

END        DO KVAR^VADPT

           KILL SDAPTYP,SDSC,%,%DT,ASKC,COV,DA,DIC,DIE,DP,DR

 +1        KILL HEY,HSI,HY,J,SB,SC,SDDIF,SDJ,SDLN,SD17,SDMAX,SDU,SDYC,SI,SL

 +2        KILL SSC,STARTDAY,STR,SDZPR,WY,X,XX,Y,S,SD,SDAP16,SDEDT,SDTY,SM

 +3        KILL SS,ST,ARG,CCX,CCXN,HX,I,PXR,SDINA,SDW,COLLAT,SDDIS,SDMM,SDMLT1

 +4        KILL SDAV,SDHX,SDSOH,SDT

 +5        QUIT