BSDRCLN.m

BSDRCLN ;cmi/flag/maw - BSD Print Restricted Clinic List by Division 10/12/2009 2:40:25 PM

 ;;5.3;PIMS;**1011**;FEB 27,2007;

 ;

 ;

 ;

 ;this report will list restricted clinics by division

 Q

 ;

MAIN ;EP - this is the main routine driver

 S BSDDIV=$$GETDIV()

 I '$G(BSDDIV) W !,"You must select a division" D EOJ Q

 D LOOP(.BSDRC,BSDDIV)

 D PRINT(.BSDRC,BSDDIV)

 D EOJ

 Q

 ;

GETDIV() ;-- get the division the user wants

 S DIC("A")="Select DIVISION:"

 D ASK^SDDIV

 I $G(Y)<0 K DIV

 Q $G(DIV)

 ;

LOOP(BSDRC,DV) ;-- loop through the HOSPITAL LOCATION file, screen on DIV and get Restricted Clinic

 N BSDDA,BSDATA,BSDDV,BSDRS,BSDCLN,BSDTYP,BSDINS,BSDTYPI

 S BSDDA=0 F  S BSDDA=$O(^SC(BSDDA)) Q:'BSDDA  D

 . S BSDATA=$G(^SC(BSDDA,0))

 . S BSDDV=$P(BSDATA,U,15)

 . Q:BSDDV'=DV

 . Q:$P($G(^SC(BSDDA,"SDPROT")),U)'="Y"

 . S BSDCLN=$$GET1^DIQ(44,BSDDA,.01)

 . S BSDTYPI=$$GET1^DIQ(44,BSDDA,8,"I")

 . S BSDTYP=$S(BSDTYPI:$P($G(^DIC(40.7,BSDTYPI,0)),U,2),1:"")

 . S BSDINS=$$GET1^DIQ(44,BSDDA,3)

 . S BSDRC(BSDDA)=BSDCLN_U_BSDTYP_U_BSDINS

 Q

 ;

PRINT(RC,DV) ;-- print the report

 D ^%ZIS

 Q:POP

 U IO

 D XHDR(DV)

 N BSDTDA,BSDTDATA,BSDTCLN,BSDTTYP,BSDTINS

 S BSDTDA=0 F  S BSDTDA=$O(RC(BSDTDA)) Q:BSDTDA=""!($D(DIRUT))  D

 . S BSDTDATA=$G(RC(BSDTDA))

 . S BSDTCLN=$P(BSDTDATA,U)

 . S BSDTTYP=$P(BSDTDATA,U,2)

 . S BSDTINS=$P(BSDTDATA,U,3)

 . D:$Y+2>IOSL HDR(DV) Q:$G(DIRUT)

 . W !,BSDTCLN,?35,BSDTTYP,?55,BSDTINS

 Q

 ;

HDR(ID) ;-- do the charge header

 K DIRUT

 I $E(IOST,1,1)="C" S DIR(0)="E" D ^DIR

 I Y=1 D XHDR(ID) Q

 S DIRUT=1

 Q

 ;

XHDR(ID) ;

 W @IOF

 S ID=$$GET1^DIQ(40.8,ID,.01)

 W "Restricted Clinic List by Division: "_ID,?60,"Date:  "_$$FMTE^XLFDT(DT)

 W !!,"Clinic",?35,"Clinic Code",?55,"Institution"

 W !

 F I=1:1:80 W "-"

 Q

 ;

EOJ ;-- kill variables and quit

 D ^%ZISC

 K BSDDIV,BSDRC

 Q

 ;

BSDRCLN   ;cmi/flag/maw - BSD Print Restricted Clinic List by Division 10/12/2009 2:40:25 PM

 +1       ;;5.3;PIMS;**1011**;FEB 27,2007;

 +2       ;

 +3       ;

 +4       ;

 +5       ;this report will list restricted clinics by division

 +6        QUIT 

 +7       ;

MAIN      ;EP - this is the main routine driver

 +1        SET BSDDIV=$$GETDIV()

 +2        IF '$GET(BSDDIV)

               WRITE !,"You must select a division"

               DO EOJ

               QUIT 

 +3        DO LOOP(.BSDRC,BSDDIV)

 +4        DO PRINT(.BSDRC,BSDDIV)

 +5        DO EOJ

 +6        QUIT 

 +7       ;

GETDIV()  ;-- get the division the user wants

 +1        SET DIC("A")="Select DIVISION:"

 +2        DO ASK^SDDIV

 +3        IF $GET(Y)<0

               KILL DIV

 +4        QUIT $GET(DIV)

 +5       ;

LOOP(BSDRC,DV) ;-- loop through the HOSPITAL LOCATION file, screen on DIV and get Restricted Clinic

 +1        NEW BSDDA,BSDATA,BSDDV,BSDRS,BSDCLN,BSDTYP,BSDINS,BSDTYPI

 +2        SET BSDDA=0

           FOR 

               SET BSDDA=$ORDER(^SC(BSDDA))

               IF 'BSDDA

                   QUIT 

               Begin DoDot:1

 +3                SET BSDATA=$GET(^SC(BSDDA,0))

 +4                SET BSDDV=$PIECE(BSDATA,U,15)

 +5                IF BSDDV'=DV

                       QUIT 

 +6                IF $PIECE($GET(^SC(BSDDA,"SDPROT")),U)'="Y"

                       QUIT 

 +7                SET BSDCLN=$$GET1^DIQ(44,BSDDA,.01)

 +8                SET BSDTYPI=$$GET1^DIQ(44,BSDDA,8,"I")

 +9                SET BSDTYP=$SELECT(BSDTYPI:$PIECE($GET(^DIC(40.7,BSDTYPI,0)),U,2),1:"")

 +10               SET BSDINS=$$GET1^DIQ(44,BSDDA,3)

 +11               SET BSDRC(BSDDA)=BSDCLN_U_BSDTYP_U_BSDINS

               End DoDot:1

 +12       QUIT 

 +13      ;

PRINT(RC,DV) ;-- print the report

 +1        DO ^%ZIS

 +2        IF POP

               QUIT 

 +3        USE IO

 +4        DO XHDR(DV)

 +5        NEW BSDTDA,BSDTDATA,BSDTCLN,BSDTTYP,BSDTINS

 +6        SET BSDTDA=0

           FOR 

               SET BSDTDA=$ORDER(RC(BSDTDA))

               IF BSDTDA=""!($DATA(DIRUT))

                   QUIT 

               Begin DoDot:1

 +7                SET BSDTDATA=$GET(RC(BSDTDA))

 +8                SET BSDTCLN=$PIECE(BSDTDATA,U)

 +9                SET BSDTTYP=$PIECE(BSDTDATA,U,2)

 +10               SET BSDTINS=$PIECE(BSDTDATA,U,3)

 +11               IF $Y+2>IOSL

                       DO HDR(DV)

                   IF $GET(DIRUT)

                       QUIT 

 +12               WRITE !,BSDTCLN,?35,BSDTTYP,?55,BSDTINS

               End DoDot:1

 +13       QUIT 

 +14      ;

HDR(ID)   ;-- do the charge header

 +1        KILL DIRUT

 +2        IF $EXTRACT(IOST,1,1)="C"

               SET DIR(0)="E"

               DO ^DIR

 +3        IF Y=1

               DO XHDR(ID)

               QUIT 

 +4        SET DIRUT=1

 +5        QUIT 

 +6       ;

XHDR(ID)  ;

 +1        WRITE @IOF

 +2        SET ID=$$GET1^DIQ(40.8,ID,.01)

 +3        WRITE "Restricted Clinic List by Division: "_ID,?60,"Date:  "_$$FMTE^XLFDT(DT)

 +4        WRITE !!,"Clinic",?35,"Clinic Code",?55,"Institution"

 +5        WRITE !

 +6        FOR I=1:1:80

               WRITE "-"

 +7        QUIT 

 +8       ;

EOJ       ;-- kill variables and quit

 +1        DO ^%ZISC

 +2        KILL BSDDIV,BSDRC

 +3        QUIT 

 +4       ;