BLRALPH.m

BLRALPH ;DAOU/ALA/EJN-Setup Participating Physicians [ 12/19/2002  7:16 AM ]

 ;;5.2;LR;**1013,1015**;NOV 18, 2002

 ;

 ; ** Program Description **

 ;  This program sets up any physician and physician

 ;  supervisor who are participating in the requirement

 ;  of electronic signature for lab results

 ;

EN ;  Check for access to this option

 ;  check if a user has one of the BLRA keys and is calling

 ;  this option from the User Toolbox option

 F BLRAKEY="BLRAZLAB","BLRAZPHY","BLRAZSUP" D

 . S RETKEY=$$KCHK^XUSRB(BLRAKEY)

 . S KEYCT=$G(KEYCT)+RETKEY

 I $G(XQSV)["XUSERTOOLS"&(KEYCT=0) Q

 ;

 ;  If the user is a participating physician, allow them

 ;  to edit their surrogates.

 I $D(^BLRALAB(9009027.1,DUZ))&($$KCHK^XUSRB("BLRAZCLRK")=0) G SUR

 ;

 ;  If the user hasn't been assigned the Lab ES Clerk key, quit

 I $$KCHK^XUSRB("BLRAZCLRK")=0 Q

 ;

CLK ; Clerk's enter/edit of the Participating Physician File

 ;D CSUR

 S DIC="^BLRALAB(9009027.1,",DIC(0)="AELMNZ",DLAYGO=9009027.1

 S DIC("A")="Select PARTICIPATING PHYSICIAN: "

 D ^DIC S DA=+Y I DA<1 G EXIT

 ;

 S DIE=DIC,DR="[BLRA PHYSICIAN]" D ^DIE

 W !!

 G CLK

 ;

EXIT K BLRAACT,DIC,DIE,DA,DR

 K IENS,TXT,BLRAPIEN,BLRASUP,BLRAPNAM

 Q

SUR ;  Set up delegated surrogates

 ;D CSUR

 S DR="[BLRA SURROGATES]"

 E  S DR="1"

 S DIE="^BLRALAB(9009027.1,",DA=DUZ

 D ^DIE

 G EXIT

 Q

 ;

CSUR ;EP - Clean-up expired surrogates in Participating Physicians File

 N BLRASUR,BLRAPHY,DA,DIK,Y

 S BLRAPHY=0

 F  S BLRAPHY=$O(^BLRALAB(9009027.1,BLRAPHY)) Q:'BLRAPHY  D

 . I $P($G(^BLRALAB(9009027.1,BLRAPHY,1,0)),U,4)<1 Q

 . S BLRASUR=0

 . F  S BLRASUR=$O(^BLRALAB(9009027.1,BLRAPHY,1,BLRASUR)) Q:'BLRASUR  D

 .. I $P($G(^BLRALAB(9009027.1,BLRAPHY,1,BLRASUR,0)),U,3)<$$DT^XLFDT() D

 ... S DA=BLRASUR,DA(1)=BLRAPHY

 ... S DIK="^BLRALAB(9009027.1,"_BLRAPHY_",1," D ^DIK

 Q

 ;

INACT ;EP

 ;   Inactivate a participating provider 

 ;D CSUR

 D EN^DDIOL("","","!!")

 S DIC="^BLRALAB(9009027.1,",DIC(0)="AEMNZ"

 S DIC("A")="Select PARTICIPATING PHYSICIAN: "

 D ^DIC S DA=+Y I DA<1 G EXIT

 S BLRAPNAM=$G(Y(0,0))

 S BLRAPIEN=DA

 ;

 ;  Check to see if a supervisor

 S BLRASUP=$S($P($G(^BLRALAB(9009027.1,DA,0)),U,2)="S":1,1:0)

 I BLRASUP S QFL=0,BLRAFSP=DA D SUP Q:QFL

 ;

 ;  Inactive physician

 D EN^DDIOL("To inactive physician "_BLRAPNAM_" enter ""I""","","!!")

 S DIE=DIC,DR=".07;I X="""" S BLRAACT=1;" D ^DIE

 I $G(BLRAACT)>0 D EN^DDIOL("The Physician "_BLRAPNAM_" has not been inactivated...","","!!") G EXIT

 ;

ISRG ;  Designate surrogate for 90 days

 K DA,DIC,DIE,DR

 S DA(1)=BLRAPIEN,DR="1",DLAYGO=9009027.11

 I '$D(^BLRALAB(9009027.1,DA(1),1,0)) S ^BLRALAB(9009027.1,DA(1),1,0)="^9009027.11^^"

 S DIC="^BLRALAB(9009027.1,"_DA(1)_",1,",DIC(0)="AEMLZ"

 S DIC("A")="Select a SURROGATE PHYSICIAN:"

 D ^DIC S DA=+Y

 I DA<1 D EN^DDIOL("** You must select a Participating Physician to be the Surrogate for 90 days. **","","!!") G ISRG

 S TERMDT=$$GET1^DIQ(200,DA,9.2,"I")

 I TERMDT'=""&(TERMDT'>DT) D EN^DDIOL("This provider has a termination date please select another.") K DA G ISRG

 S IENS=$$IENS^DILF(.DA)

 S DR="@2;.02;I X="""" D EN^DDIOL(""You must enter a START DATE."") S Y=""@2"";S ENDT=$$FMADD^XLFDT(($$GET1^DIQ(9009027.11,IENS,.02,""I"")),90);.03////^S X=ENDT;S TXT=""END DATE: ""_$$FMTE^XLFDT(ENDT);D EN^DDIOL(TXT)"

 S DIE=DIC,DIE("NO^")="BACK" D ^DIE

 ;

 K DIE,DA,DIK,DIC,BLRAS,BLRVD,BLRAP,LRIDT,LRSS,LRDFN,TERMDT

 K BLRAACT,BLRAFPH,BLRATPH,DIR,BLRADATA,BLRARFL,BLRARPHY

 G INACT

 Q

SUP ;  Ask to change supervisor to

 NEW DIR

 S DIR("A",1)=" "

 S DIR("A",2)="This physician is a designated supervisor.  All subordinate"

 S DIR("A",3)="participating physicians must have a valid supervisor."

 S DIR("A")="DO YOU WISH TO REASSIGN TO ANOTHER SUPERVISOR NOW"

 S DIR(0)="Y"

 D ^DIR

 I $G(Y)'=1 S QFL=1 Q

 I $G(Y)=1 D  Q:QFL

 . S DIC="^BLRALAB(9009027.1,",DIC(0)="AEMNZ",DIC("S")="I $P(^(0),U,2)=""S"""

 . D ^DIC I Y<1 S QFL=1 Q

 . S BLRATSP=+Y

 . S BLRJ="" F  S BLRJ=$O(^BLRALAB(9009027.1,"C",BLRAFSP,BLRJ)) Q:'BLRJ  D

 .. S BLRALY(9009027.1,BLRJ_",",.03)=BLRATSP

 . D FILE^DIE("","BLRALY")

 Q

BLRALPH   ;DAOU/ALA/EJN-Setup Participating Physicians [ 12/19/2002  7:16 AM ]

 +1       ;;5.2;LR;**1013,1015**;NOV 18, 2002

 +2       ;

 +3       ; ** Program Description **

 +4       ;  This program sets up any physician and physician

 +5       ;  supervisor who are participating in the requirement

 +6       ;  of electronic signature for lab results

 +7       ;

EN        ;  Check for access to this option

 +1       ;  check if a user has one of the BLRA keys and is calling

 +2       ;  this option from the User Toolbox option

 +3        FOR BLRAKEY="BLRAZLAB","BLRAZPHY","BLRAZSUP"

               Begin DoDot:1

 +4                SET RETKEY=$$KCHK^XUSRB(BLRAKEY)

 +5                SET KEYCT=$GET(KEYCT)+RETKEY

               End DoDot:1

 +6        IF $GET(XQSV)["XUSERTOOLS"&(KEYCT=0)

               QUIT 

 +7       ;

 +8       ;  If the user is a participating physician, allow them

 +9       ;  to edit their surrogates.

 +10       IF $DATA(^BLRALAB(9009027.1,DUZ))&($$KCHK^XUSRB("BLRAZCLRK")=0)

               GOTO SUR

 +11      ;

 +12      ;  If the user hasn't been assigned the Lab ES Clerk key, quit

 +13       IF $$KCHK^XUSRB("BLRAZCLRK")=0

               QUIT 

 +14      ;

CLK       ; Clerk's enter/edit of the Participating Physician File

 +1       ;D CSUR

 +2        SET DIC="^BLRALAB(9009027.1,"

           SET DIC(0)="AELMNZ"

           SET DLAYGO=9009027.1

 +3        SET DIC("A")="Select PARTICIPATING PHYSICIAN: "

 +4        DO ^DIC

           SET DA=+Y

           IF DA<1

               GOTO EXIT

 +5       ;

 +6        SET DIE=DIC

           SET DR="[BLRA PHYSICIAN]"

           DO ^DIE

 +7        WRITE !!

 +8        GOTO CLK

 +9       ;

EXIT       KILL BLRAACT,DIC,DIE,DA,DR

 +1        KILL IENS,TXT,BLRAPIEN,BLRASUP,BLRAPNAM

 +2        QUIT 

SUR       ;  Set up delegated surrogates

 +1       ;D CSUR

 +2        SET DR="[BLRA SURROGATES]"

 +3       IF '$TEST

               SET DR="1"

 +4        SET DIE="^BLRALAB(9009027.1,"

           SET DA=DUZ

 +5        DO ^DIE

 +6        GOTO EXIT

 +7        QUIT 

 +8       ;

CSUR      ;EP - Clean-up expired surrogates in Participating Physicians File

 +1        NEW BLRASUR,BLRAPHY,DA,DIK,Y

 +2        SET BLRAPHY=0

 +3        FOR 

               SET BLRAPHY=$ORDER(^BLRALAB(9009027.1,BLRAPHY))

               IF 'BLRAPHY

                   QUIT 

               Begin DoDot:1

 +4                IF $PIECE($GET(^BLRALAB(9009027.1,BLRAPHY,1,0)),U,4)<1

                       QUIT 

 +5                SET BLRASUR=0

 +6                FOR 

                       SET BLRASUR=$ORDER(^BLRALAB(9009027.1,BLRAPHY,1,BLRASUR))

                       IF 'BLRASUR

                           QUIT 

                       Begin DoDot:2

 +7                        IF $PIECE($GET(^BLRALAB(9009027.1,BLRAPHY,1,BLRASUR,0)),U,3)<$$DT^XLFDT()

                               Begin DoDot:3

 +8                                SET DA=BLRASUR

                                   SET DA(1)=BLRAPHY

 +9                                SET DIK="^BLRALAB(9009027.1,"_BLRAPHY_",1,"

                                   DO ^DIK

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +10       QUIT 

 +11      ;

INACT     ;EP

 +1       ;   Inactivate a participating provider 

 +2       ;D CSUR

 +3        DO EN^DDIOL("","","!!")

 +4        SET DIC="^BLRALAB(9009027.1,"

           SET DIC(0)="AEMNZ"

 +5        SET DIC("A")="Select PARTICIPATING PHYSICIAN: "

 +6        DO ^DIC

           SET DA=+Y

           IF DA<1

               GOTO EXIT

 +7        SET BLRAPNAM=$GET(Y(0,0))

 +8        SET BLRAPIEN=DA

 +9       ;

 +10      ;  Check to see if a supervisor

 +11       SET BLRASUP=$SELECT($PIECE($GET(^BLRALAB(9009027.1,DA,0)),U,2)="S":1,1:0)

 +12       IF BLRASUP

               SET QFL=0

               SET BLRAFSP=DA

               DO SUP

               IF QFL

                   QUIT 

 +13      ;

 +14      ;  Inactive physician

 +15       DO EN^DDIOL("To inactive physician "_BLRAPNAM_" enter ""I""","","!!")

 +16       SET DIE=DIC

           SET DR=".07;I X="""" S BLRAACT=1;"

           DO ^DIE

 +17       IF $GET(BLRAACT)>0

               DO EN^DDIOL("The Physician "_BLRAPNAM_" has not been inactivated...","","!!")

               GOTO EXIT

 +18      ;

ISRG      ;  Designate surrogate for 90 days

 +1        KILL DA,DIC,DIE,DR

 +2        SET DA(1)=BLRAPIEN

           SET DR="1"

           SET DLAYGO=9009027.11

 +3        IF '$DATA(^BLRALAB(9009027.1,DA(1),1,0))

               SET ^BLRALAB(9009027.1,DA(1),1,0)="^9009027.11^^"

 +4        SET DIC="^BLRALAB(9009027.1,"_DA(1)_",1,"

           SET DIC(0)="AEMLZ"

 +5        SET DIC("A")="Select a SURROGATE PHYSICIAN:"

 +6        DO ^DIC

           SET DA=+Y

 +7        IF DA<1

               DO EN^DDIOL("** You must select a Participating Physician to be the Surrogate for 90 days. **","","!!")

               GOTO ISRG

 +8        SET TERMDT=$$GET1^DIQ(200,DA,9.2,"I")

 +9        IF TERMDT'=""&(TERMDT'>DT)

               DO EN^DDIOL("This provider has a termination date please select another.")

               KILL DA

               GOTO ISRG

 +10       SET IENS=$$IENS^DILF(.DA)

 +11       SET DR="@2;.02;I X="""" D EN^DDIOL(""You must enter a START DATE."") S Y=""@2"";S ENDT=$$FMADD^XLFDT(($$GET1^DIQ(9009027.11,IENS,.02,""I"")),90);.03////^S X=ENDT;S TXT=""END DATE: ""_$$FMTE^XLFDT(ENDT);D EN^DDIOL(TXT)"

 +12       SET DIE=DIC

           SET DIE("NO^")="BACK"

           DO ^DIE

 +13      ;

 +14       KILL DIE,DA,DIK,DIC,BLRAS,BLRVD,BLRAP,LRIDT,LRSS,LRDFN,TERMDT

 +15       KILL BLRAACT,BLRAFPH,BLRATPH,DIR,BLRADATA,BLRARFL,BLRARPHY

 +16       GOTO INACT

 +17       QUIT 

SUP       ;  Ask to change supervisor to

 +1        NEW DIR

 +2        SET DIR("A",1)=" "

 +3        SET DIR("A",2)="This physician is a designated supervisor.  All subordinate"

 +4        SET DIR("A",3)="participating physicians must have a valid supervisor."

 +5        SET DIR("A")="DO YOU WISH TO REASSIGN TO ANOTHER SUPERVISOR NOW"

 +6        SET DIR(0)="Y"

 +7        DO ^DIR

 +8        IF $GET(Y)'=1

               SET QFL=1

               QUIT 

 +9        IF $GET(Y)=1

               Begin DoDot:1

 +10               SET DIC="^BLRALAB(9009027.1,"

                   SET DIC(0)="AEMNZ"

                   SET DIC("S")="I $P(^(0),U,2)=""S"""

 +11               DO ^DIC

                   IF Y<1

                       SET QFL=1

                       QUIT 

 +12               SET BLRATSP=+Y

 +13               SET BLRJ=""

                   FOR 

                       SET BLRJ=$ORDER(^BLRALAB(9009027.1,"C",BLRAFSP,BLRJ))

                       IF 'BLRJ

                           QUIT 

                       Begin DoDot:2

 +14                       SET BLRALY(9009027.1,BLRJ_",",.03)=BLRATSP

                       End DoDot:2

 +15               DO FILE^DIE("","BLRALY")

               End DoDot:1

               IF QFL

                   QUIT 

 +16       QUIT