PSS1P126.m

PSS1P126 ;SMT - PSS*1*126 POST INSTALL ; 8/21/07 10:48am

 ;;1.0; PHARMACY DATA MANAGEMENT;**126**; 4/26/07;Build 11

 ;

 ;This routine will send mail to anyone holding the "PSNMGR" key

 ; as well as the installing user, a list of drugs whos DEA code

 ; is subject to change as the result of PSS*1*126 and PSO*7*206

 ; DEA code changes.

 ;

EN N XMDUZ,XMSUB,XMTEXT,DIFROM,XMY,X,CNT,OP,SPC,Y,VAR

 S X=0,CNT=8

 F  S X=$O(^PSDRUG(X)) Q:'X  I $G(^PSDRUG(X,0))]"",($P(^PSDRUG(X,0),"^",3)["3A")!($P(^PSDRUG(X,0),"^",3)["4A")!($P(^PSDRUG(X,0),"^",3)["5A") D  S CNT=CNT+1

 .S SPC(0)=X,SPC(10)=$P(^PSDRUG(X,0),"^")

 .S (Y,VAR)="" F  S Y=$O(SPC(Y)) Q:Y=""  F  Q:$L($G(VAR))>Y  S:$L($G(VAR))<Y VAR=VAR_" " S:$L(VAR)=Y VAR=VAR_SPC(Y)

 .S OP(CNT)=VAR

 S OP(1)="This is an alert containing drugs with DEA schedules that are going to change."

 S OP(2)="The following drugs should be reviewed by pharmacy and verified "

 S OP(3)="that they contain the correct scheduling after the changes. Please "

 S OP(4)="see the patch description for a corresponding table and decide what "

 S OP(5)="the new codes should be."

 S OP(6)="There are a total of "_(CNT-8)_" drug(s) that have changed."

 S OP(7)="IEN       NAME"

 S XMDUZ="POSTMASTER",XMSUB="DEA CODES SUBJECT TO CHANGE PLEASE REVIEW",XMTEXT="OP("

 S XMY(DUZ)=""

 S X="" F  S X=$O(^XUSEC("PSNMGR",X)) Q:'X  S XMY(X)=""

 D ^XMD

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSS1P126   1386     printed  Apr 09, 2024@21:32:06                                                                                                                                                                                                    Page 2

PSS1P126  ;SMT - PSS*1*126 POST INSTALL ; 8/21/07 10:48am

 +1       ;;1.0; PHARMACY DATA MANAGEMENT;**126**; 4/26/07;Build 11

 +2       ;

 +3       ;This routine will send mail to anyone holding the "PSNMGR" key

 +4       ; as well as the installing user, a list of drugs whos DEA code

 +5       ; is subject to change as the result of PSS*1*126 and PSO*7*206

 +6       ; DEA code changes.

 +7       ;

EN         NEW XMDUZ,XMSUB,XMTEXT,DIFROM,XMY,X,CNT,OP,SPC,Y,VAR

 +1        SET X=0

           SET CNT=8

 +2        FOR 

               SET X=$ORDER(^PSDRUG(X))

               if 'X

                   QUIT 

               IF $GET(^PSDRUG(X,0))]""

                   IF ($PIECE(^PSDRUG(X,0),"^",3)["3A")!($PIECE(^PSDRUG(X,0),"^",3)["4A")!($PIECE(^PSDRUG(X,0),"^",3)["5A")

                       Begin DoDot:1

 +3                        SET SPC(0)=X

                           SET SPC(10)=$PIECE(^PSDRUG(X,0),"^")

 +4                        SET (Y,VAR)=""

                           FOR 

                               SET Y=$ORDER(SPC(Y))

                               if Y=""

                                   QUIT 

                               FOR 

                                   if $LENGTH($GET(VAR))>Y

                                       QUIT 

                                   if $LENGTH($GET(VAR))<Y

                                       SET VAR=VAR_" "

                                   if $LENGTH(VAR)=Y

                                       SET VAR=VAR_SPC(Y)

 +5                        SET OP(CNT)=VAR

                       End DoDot:1

                       SET CNT=CNT+1

 +6        SET OP(1)="This is an alert containing drugs with DEA schedules that are going to change."

 +7        SET OP(2)="The following drugs should be reviewed by pharmacy and verified "

 +8        SET OP(3)="that they contain the correct scheduling after the changes. Please "

 +9        SET OP(4)="see the patch description for a corresponding table and decide what "

 +10       SET OP(5)="the new codes should be."

 +11       SET OP(6)="There are a total of "_(CNT-8)_" drug(s) that have changed."

 +12       SET OP(7)="IEN       NAME"

 +13       SET XMDUZ="POSTMASTER"

           SET XMSUB="DEA CODES SUBJECT TO CHANGE PLEASE REVIEW"

           SET XMTEXT="OP("

 +14       SET XMY(DUZ)=""

 +15       SET X=""

           FOR 

               SET X=$ORDER(^XUSEC("PSNMGR",X))

               if 'X

                   QUIT 

               SET XMY(X)=""

 +16       DO ^XMD

 +17       QUIT