Routine: PSS1P178

PSS1P178 ;BP/CMF - PATCH PSS*1*178 Pre/Post-Init Rtn ;04/20/2010

 ;;1.0;PHARMACY DATA MANAGEMENT;**178**;9/30/97;Build 14

ENV ;environment check

 S XPDABORT=""

 ;D PRODCHK(.XPDABORT) I XPDABORT=2 Q  ;comment this line out after sprint 3

 D PROGCHK(.XPDABORT) ;checks programmer variables

 I XPDABORT="" K XPDABORT

PRODCHK(XPDABORT) ;checks for test/production account

 I $$PROD^XUPROD DO

 . D BMES^XPDUTL("******")

 . D MES^XPDUTL("PSS*1*178 is not yet ready for production accounts.")

 . D MES^XPDUTL("Installation aborted.")

 . D MES^XPDUTL("******")

 . S XPDABORT=2

PROGCHK(XPDABORT) ;checks for necessary programmer variables

 I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") DO

 . D BMES^XPDUTL("******")

 . D MES^XPDUTL("Your programming variables are not set up properly.")

 . D MES^XPDUTL("Installation aborted.")

 . D MES^XPDUTL("******")

 . S XPDABORT=2

PRE ;; hook for pre install actions

POST ;; hook for post install actions

 D BMES^XPDUTL("Now running Dose Unit and Dose Unit Conversion File updates...")

MAIN ; Update entries in DOSE UNITS file (51.24)

 K XFAIL

 F CT=1:1:8 Q:'$G(CT)  D @CT D BMES^XPDUTL("Update "_CT_" of 8 "_$S($G(XFAIL)=1:"FAILED",1:"PASSED")) K XFAIL

 K DIE,DR,DA,XFAIL,CT,XUMF

 D BMES^XPDUTL("-- UPDATE COMPLETE --")

1 ;Verify FDB DOSE Unit = APPLICATORFUL(S) Change as needed   (2.6.23.2)

 ;^PS(51.24,2,0)="APPLICATORFUL(S)^APPLICATORFUL^1"

 K DIE,DR,DA

 S DA=2,XUMF=1

 S DIE="^PS(51.24,",DR="1////"_"APPLICATORFUL(S)"

 D ^DIE

 I $P($G(^PS(51.24,2,0)),"^",2)'="APPLICATORFUL(S)" S XFAIL=1 Q

2 ;Verify Synonym = APPLICATORFUL/S - Correct if needed  Return Synonyms to correct state

 ;^PS(51.24,2,1,6,0)="APPLICATORFUL/S"

 K DIE,DR,DA

 S DA=6,DA(1)=2,XUMF=1

 S DIE="^PS(51.24,DA(1),1,",DR=".01////"_"APPLICATORFUL/S"

 D ^DIE

 I $G(^PS(51.24,2,1,6,0))'="APPLICATORFUL/S" S XFAIL=1 Q

3 ;Verify FDB DOSE Unit = SUPPOSITORY(IES) Change as needed  (2.6.23.3)

 ;^PS(51.24,40,0)="SUPPOSITORY(IES)^SUPPOSITORY^1"

 K DIE,DR,DA

 S DA=40,XUMF=1

 S DIE="^PS(51.24,",DR="1////"_"SUPPOSITORY(IES)"

 D ^DIE

 I $P($G(^PS(51.24,40,0)),"^",2)'="SUPPOSITORY(IES)" S XFAIL=1 Q

4 ;Verify Synonym = SUPPOSITORY/IES and correct if needed

 ;^PS(51.24,40,1,4,0)="SUPPOSITORY/IES"

 K DIE,DR,DA

 S DA=4,DA(1)=40,XUMF=1

 S DIE="^PS(51.24,DA(1),1,",DR=".01////"_"SUPPOSITORY/IES"

 D ^DIE

 I $G(^PS(51.24,40,1,4,0))'="SUPPOSITORY/IES" S XFAIL=1 Q

5 ;CHANGE APPLICATORFUL/S to APPLICATORFUL(S) (2.6.21.10)

 ;^PS(51.25,3,0)="APPLICATORFUL/S"

 K DIE,DR,DA

 S DA=3,XUMF=1

 S DIE="^PS(51.25,",DR=".01////"_"APPLICATORFUL(S)"

 D ^DIE

 I $G(^PS(51.25,3,0))'="APPLICATORFUL(S)" S XFAIL=1 Q

6 ;CHANGE SUPPOSITORY/IES to SUPPOSITORY(IES)  (2.6.21.9)

 ;^PS(51.25,9,1,18,0)="SUPPOSITORY/IES^1"

 K DIE,DR,DA

 S DA=18,DA(1)=9,XUMF=1

 S DIE="^PS(51.25,DA(1),1,",DR=".01////"_"SUPPOSITORY(IES)"

 D ^DIE

 I $P($G(^PS(51.25,9,1,18,0)),U,1)'="SUPPOSITORY(IES)" S XFAIL=1 Q

7 ;CHANGE SUPPOSITORY/IES to SUPPOSITORY(IES) (2.6.21.7)

 ;^PS(51.25,55,0)="SUPPOSITORY/IES"

 K DIE,DR,DA

 S DA=55,XUMF=1

 S DIE="^PS(51.25,",DR=".01////"_"SUPPOSITORY(IES)"

 D ^DIE

 I ($G(^PS(51.25,55,0)))'="SUPPOSITORY(IES)" S XFAIL=1 Q

8 ;APPLICATORFUL/S to APPLICATORFUL(S) (2.6.21.8)

 ;^PS(51.25,67,1,1,0)="APPLICATORFUL/S^1"

 K DIE,DR,DA

 S DA=1,DA(1)=67,XUMF=1

 S DIE="^PS(51.25,DA(1),1,",DR=".01////"_"APPLICATORFUL(S)"

 D ^DIE

 I $P($G(^PS(51.25,67,1,1,0)),U,1)'="APPLICATORFUL(S)" S XFAIL=1 Q

RESET ;

 W !,"RESET 51.24!"

R1 ;^PS(51.24,2,0)="APPLICATORFUL(S)^APPLICATORFUL^1"

 K DIE,DR,DA

 S DA=2,XUMF=1

 S DIE="^PS(51.24,",DR="1////"_"APPLICATORFUL"

 D ^DIE

 I $P($G(^PS(51.24,2,0)),"^",2)'="APPLICATORFUL" W !,"R1 FAILED!!",! G R2

 W !,"R1 PASSED!!"

R2 ;^PS(51.24,2,1,6,0)="APPLICATORFUL/S"

 K DIE,DR,DA

 S DA=6,DA(1)=2,XUMF=1

 S DIE="^PS(51.24,DA(1),1,",DR=".01////"_"APPLICATORFUL/S"

 D ^DIE

 I $G(^PS(51.24,2,1,6,0))'="APPLICATORFUL/S" W !,"R2 FAILED!!" G R3

 W !,"R2 PASSED!!"

R3 ;^PS(51.24,40,0)="SUPPOSITORY(IES)^SUPPOSITORY^1"

 K DIE,DR,DA

 S DA=40,XUMF=1

 S DIE="^PS(51.24,",DR="1////"_"SUPPOSITORY"

 D ^DIE

 I $P($G(^PS(51.24,40,0)),"^",2)'="SUPPOSITORY" W !,"R3 FAILED!!" G R4

 W !,"R3 PASSED!!"

R4 ;

 ;^PS(51.24,40,1,4,0)="SUPPOSITORY/IES"

 ;Reset SUPPOSITORY(IES) TO SUPPOSITORY/IES for testing

 N DIE,DR,DA

 S DA=4,DA(1)=40,XUMF=1

 S DIE="^PS(51.24,DA(1),1,",DR=".01////"_"SUPPOSITORY/IES"

 D ^DIE

 I $G(^PS(51.24,40,1,4,0))'="SUPPOSITORY/IES" W !,"R4 Failed!" G R5

 W !,"R4 PASSED!!"

 W !!,"RESET 51.25!"

R5 ;

 ;^PS(51.25,3,0)="APPLICATORFUL/S"

 ;RESET APPLICATORFUL(S) to APPLICATORFUL/S for testing

 K DIE,DR,DA

 S DA=3,XUMF=1

 S DIE="^PS(51.25,",DR=".01////"_"APPLICATORFUL/S"

 D ^DIE

 I $G(^PS(51.25,3,0))'="APPLICATORFUL/S" W !,"R5 Failed!" G R6

 W !,"R5 PASSED!!"

R6 ;

 ;^PS(51.25,9,1,18,0)="SUPPOSITORY/IES^1"

 ;RESET SUPPOSITORY(IES) to SUPPOSITORY/IES

 N DIE,DR,DA

 S DA=18,DA(1)=9,XUMF=1

 S DIE="^PS(51.25,DA(1),1,",DR=".01////"_"SUPPOSITORY/IES"

 D ^DIE

 I $P($G(^PS(51.25,9,1,18,0)),U,1)'="SUPPOSITORY/IES" W !,"R6 Failed!" G R7

 W !,"R6 PASSED!!"

R7 ;

 ;^PS(51.25,55,0)="SUPPOSITORY/IES"

 ;RESET SUPPOSITORY(IES) to SUPPOSITORY/IES

 ;^PS(51.25,55,0)="SUPPOSITORY/IES"

 K DIE,DR,DA

 S DA=55,XUMF=1

 S DIE="^PS(51.25,",DR=".01////"_"SUPPOSITORY/IES"

 D ^DIE

 I ($G(^PS(51.25,55,0)))'="SUPPOSITORY/IES" W !,"R7 Failed!" G R8

 W !,"R7 PASSED!!"

R8 ;

 ;^PS(51.25,67,1,1,0)="APPLICATORFUL/S^1"

 ;RESET APPLICATORFUL(S) to APPLICATORFUL/S

 N DIE,DR,DA

 S DA=1,DA(1)=67,XUMF=1

 S DIE="^PS(51.25,DA(1),1,",DR=".01////"_"APPLICATORFUL/S"

 D ^DIE

 I $P($G(^PS(51.25,67,1,1,0)),U,1)'="APPLICATORFUL/S"  W !,"R8 Failed!" Q

 W !,"R8 PASSED!!",!!!

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSS1P178   5956     printed  Mar 13, 2025@21:33:50                                                                                                                                                                                                    Page 2

PSS1P178  ;BP/CMF - PATCH PSS*1*178 Pre/Post-Init Rtn ;04/20/2010

 +1       ;;1.0;PHARMACY DATA MANAGEMENT;**178**;9/30/97;Build 14

 +2       ;

ENV       ;environment check

 +1        SET XPDABORT=""

 +2       ;D PRODCHK(.XPDABORT) I XPDABORT=2 Q  ;comment this line out after sprint 3

 +3       ;checks programmer variables

           DO PROGCHK(.XPDABORT)

 +4        IF XPDABORT=""

               KILL XPDABORT

 +5        QUIT

 +6       ;

PRODCHK(XPDABORT) ;checks for test/production account

 +1        IF $$PROD^XUPROD

               Begin DoDot:1

 +2                DO BMES^XPDUTL("******")

 +3                DO MES^XPDUTL("PSS*1*178 is not yet ready for production accounts.")

 +4                DO MES^XPDUTL("Installation aborted.")

 +5                DO MES^XPDUTL("******")

 +6                SET XPDABORT=2

               End DoDot:1

 +7        QUIT

 +8       ;

PROGCHK(XPDABORT) ;checks for necessary programmer variables

 +1        IF '$GET(DUZ)!($GET(DUZ(0))'="@")!('$GET(DT))!($GET(U)'="^")

               Begin DoDot:1

 +2                DO BMES^XPDUTL("******")

 +3                DO MES^XPDUTL("Your programming variables are not set up properly.")

 +4                DO MES^XPDUTL("Installation aborted.")

 +5                DO MES^XPDUTL("******")

 +6                SET XPDABORT=2

               End DoDot:1

 +7        QUIT

 +8       ;

PRE       ;; hook for pre install actions

 +1        QUIT

 +2       ;

POST      ;; hook for post install actions

 +1       ;

 +2       ;

 +3        DO BMES^XPDUTL("Now running Dose Unit and Dose Unit Conversion File updates...")

 +4       ;

MAIN      ; Update entries in DOSE UNITS file (51.24)

 +1        KILL XFAIL

 +2        FOR CT=1:1:8

               if '$GET(CT)

                   QUIT

               DO @CT

               DO BMES^XPDUTL("Update "_CT_" of 8 "_$SELECT($GET(XFAIL)=1:"FAILED",1:"PASSED"))

               KILL XFAIL

 +3        KILL DIE,DR,DA,XFAIL,CT,XUMF

 +4        DO BMES^XPDUTL("-- UPDATE COMPLETE --")

 +5        QUIT

1         ;Verify FDB DOSE Unit = APPLICATORFUL(S) Change as needed   (2.6.23.2)

 +1       ;

 +2       ;^PS(51.24,2,0)="APPLICATORFUL(S)^APPLICATORFUL^1"

 +3       ;

 +4        KILL DIE,DR,DA

 +5        SET DA=2

           SET XUMF=1

 +6        SET DIE="^PS(51.24,"

           SET DR="1////"_"APPLICATORFUL(S)"

 +7        DO ^DIE

 +8        IF $PIECE($GET(^PS(51.24,2,0)),"^",2)'="APPLICATORFUL(S)"

               SET XFAIL=1

               QUIT

 +9        QUIT

 +10      ;

2         ;Verify Synonym = APPLICATORFUL/S - Correct if needed  Return Synonyms to correct state

 +1       ;

 +2       ;^PS(51.24,2,1,6,0)="APPLICATORFUL/S"

 +3       ;

 +4        KILL DIE,DR,DA

 +5        SET DA=6

           SET DA(1)=2

           SET XUMF=1

 +6        SET DIE="^PS(51.24,DA(1),1,"

           SET DR=".01////"_"APPLICATORFUL/S"

 +7        DO ^DIE

 +8        IF $GET(^PS(51.24,2,1,6,0))'="APPLICATORFUL/S"

               SET XFAIL=1

               QUIT

 +9        QUIT

 +10      ;

3         ;Verify FDB DOSE Unit = SUPPOSITORY(IES) Change as needed  (2.6.23.3)

 +1       ;

 +2       ;^PS(51.24,40,0)="SUPPOSITORY(IES)^SUPPOSITORY^1"

 +3       ;

 +4        KILL DIE,DR,DA

 +5        SET DA=40

           SET XUMF=1

 +6        SET DIE="^PS(51.24,"

           SET DR="1////"_"SUPPOSITORY(IES)"

 +7        DO ^DIE

 +8        IF $PIECE($GET(^PS(51.24,40,0)),"^",2)'="SUPPOSITORY(IES)"

               SET XFAIL=1

               QUIT

 +9        QUIT

 +10      ;

4         ;Verify Synonym = SUPPOSITORY/IES and correct if needed

 +1       ;

 +2       ;^PS(51.24,40,1,4,0)="SUPPOSITORY/IES"

 +3       ;

 +4        KILL DIE,DR,DA

 +5        SET DA=4

           SET DA(1)=40

           SET XUMF=1

 +6        SET DIE="^PS(51.24,DA(1),1,"

           SET DR=".01////"_"SUPPOSITORY/IES"

 +7        DO ^DIE

 +8        IF $GET(^PS(51.24,40,1,4,0))'="SUPPOSITORY/IES"

               SET XFAIL=1

               QUIT

 +9        QUIT

 +10      ;

5         ;CHANGE APPLICATORFUL/S to APPLICATORFUL(S) (2.6.21.10)

 +1       ;

 +2       ;^PS(51.25,3,0)="APPLICATORFUL/S"

 +3       ;

 +4        KILL DIE,DR,DA

 +5        SET DA=3

           SET XUMF=1

 +6        SET DIE="^PS(51.25,"

           SET DR=".01////"_"APPLICATORFUL(S)"

 +7        DO ^DIE

 +8        IF $GET(^PS(51.25,3,0))'="APPLICATORFUL(S)"

               SET XFAIL=1

               QUIT

 +9        QUIT

 +10      ;

6         ;CHANGE SUPPOSITORY/IES to SUPPOSITORY(IES)  (2.6.21.9)

 +1       ;

 +2       ;^PS(51.25,9,1,18,0)="SUPPOSITORY/IES^1"

 +3       ;

 +4        KILL DIE,DR,DA

 +5        SET DA=18

           SET DA(1)=9

           SET XUMF=1

 +6        SET DIE="^PS(51.25,DA(1),1,"

           SET DR=".01////"_"SUPPOSITORY(IES)"

 +7        DO ^DIE

 +8        IF $PIECE($GET(^PS(51.25,9,1,18,0)),U,1)'="SUPPOSITORY(IES)"

               SET XFAIL=1

               QUIT

 +9        QUIT

 +10      ;

7         ;CHANGE SUPPOSITORY/IES to SUPPOSITORY(IES) (2.6.21.7)

 +1       ;

 +2       ;^PS(51.25,55,0)="SUPPOSITORY/IES"

 +3       ;

 +4        KILL DIE,DR,DA

 +5        SET DA=55

           SET XUMF=1

 +6        SET DIE="^PS(51.25,"

           SET DR=".01////"_"SUPPOSITORY(IES)"

 +7        DO ^DIE

 +8        IF ($GET(^PS(51.25,55,0)))'="SUPPOSITORY(IES)"

               SET XFAIL=1

               QUIT

 +9        QUIT

 +10      ;

8         ;APPLICATORFUL/S to APPLICATORFUL(S) (2.6.21.8)

 +1       ;

 +2       ;^PS(51.25,67,1,1,0)="APPLICATORFUL/S^1"

 +3       ;

 +4        KILL DIE,DR,DA

 +5        SET DA=1

           SET DA(1)=67

           SET XUMF=1

 +6        SET DIE="^PS(51.25,DA(1),1,"

           SET DR=".01////"_"APPLICATORFUL(S)"

 +7        DO ^DIE

 +8        IF $PIECE($GET(^PS(51.25,67,1,1,0)),U,1)'="APPLICATORFUL(S)"

               SET XFAIL=1

               QUIT

 +9        QUIT

 +10      ;

 +11      ;

RESET     ;

 +1       ;

 +2        WRITE !,"RESET 51.24!"

 +3       ;

R1        ;^PS(51.24,2,0)="APPLICATORFUL(S)^APPLICATORFUL^1"

 +1       ;

 +2        KILL DIE,DR,DA

 +3        SET DA=2

           SET XUMF=1

 +4        SET DIE="^PS(51.24,"

           SET DR="1////"_"APPLICATORFUL"

 +5        DO ^DIE

 +6        IF $PIECE($GET(^PS(51.24,2,0)),"^",2)'="APPLICATORFUL"

               WRITE !,"R1 FAILED!!",!

               GOTO R2

 +7        WRITE !,"R1 PASSED!!"

 +8       ;

R2        ;^PS(51.24,2,1,6,0)="APPLICATORFUL/S"

 +1       ;

 +2        KILL DIE,DR,DA

 +3        SET DA=6

           SET DA(1)=2

           SET XUMF=1

 +4        SET DIE="^PS(51.24,DA(1),1,"

           SET DR=".01////"_"APPLICATORFUL/S"

 +5        DO ^DIE

 +6        IF $GET(^PS(51.24,2,1,6,0))'="APPLICATORFUL/S"

               WRITE !,"R2 FAILED!!"

               GOTO R3

 +7        WRITE !,"R2 PASSED!!"

 +8       ;

R3        ;^PS(51.24,40,0)="SUPPOSITORY(IES)^SUPPOSITORY^1"

 +1       ;

 +2        KILL DIE,DR,DA

 +3        SET DA=40

           SET XUMF=1

 +4        SET DIE="^PS(51.24,"

           SET DR="1////"_"SUPPOSITORY"

 +5        DO ^DIE

 +6        IF $PIECE($GET(^PS(51.24,40,0)),"^",2)'="SUPPOSITORY"

               WRITE !,"R3 FAILED!!"

               GOTO R4

 +7        WRITE !,"R3 PASSED!!"

 +8       ;

R4        ;

 +1       ;^PS(51.24,40,1,4,0)="SUPPOSITORY/IES"

 +2       ;Reset SUPPOSITORY(IES) TO SUPPOSITORY/IES for testing

 +3        NEW DIE,DR,DA

 +4        SET DA=4

           SET DA(1)=40

           SET XUMF=1

 +5        SET DIE="^PS(51.24,DA(1),1,"

           SET DR=".01////"_"SUPPOSITORY/IES"

 +6        DO ^DIE

 +7        IF $GET(^PS(51.24,40,1,4,0))'="SUPPOSITORY/IES"

               WRITE !,"R4 Failed!"

               GOTO R5

 +8        WRITE !,"R4 PASSED!!"

 +9       ;

 +10       WRITE !!,"RESET 51.25!"

 +11      ;

R5        ;

 +1       ;^PS(51.25,3,0)="APPLICATORFUL/S"

 +2       ;RESET APPLICATORFUL(S) to APPLICATORFUL/S for testing

 +3       ;

 +4        KILL DIE,DR,DA

 +5        SET DA=3

           SET XUMF=1

 +6        SET DIE="^PS(51.25,"

           SET DR=".01////"_"APPLICATORFUL/S"

 +7        DO ^DIE

 +8        IF $GET(^PS(51.25,3,0))'="APPLICATORFUL/S"

               WRITE !,"R5 Failed!"

               GOTO R6

 +9        WRITE !,"R5 PASSED!!"

 +10      ;

R6        ;

 +1       ;^PS(51.25,9,1,18,0)="SUPPOSITORY/IES^1"

 +2       ;RESET SUPPOSITORY(IES) to SUPPOSITORY/IES

 +3       ;

 +4        NEW DIE,DR,DA

 +5        SET DA=18

           SET DA(1)=9

           SET XUMF=1

 +6        SET DIE="^PS(51.25,DA(1),1,"

           SET DR=".01////"_"SUPPOSITORY/IES"

 +7        DO ^DIE

 +8        IF $PIECE($GET(^PS(51.25,9,1,18,0)),U,1)'="SUPPOSITORY/IES"

               WRITE !,"R6 Failed!"

               GOTO R7

 +9        WRITE !,"R6 PASSED!!"

 +10      ;

R7        ;

 +1       ;^PS(51.25,55,0)="SUPPOSITORY/IES"

 +2       ;RESET SUPPOSITORY(IES) to SUPPOSITORY/IES

 +3       ;

 +4       ;^PS(51.25,55,0)="SUPPOSITORY/IES"

 +5       ;

 +6        KILL DIE,DR,DA

 +7        SET DA=55

           SET XUMF=1

 +8        SET DIE="^PS(51.25,"

           SET DR=".01////"_"SUPPOSITORY/IES"

 +9        DO ^DIE

 +10       IF ($GET(^PS(51.25,55,0)))'="SUPPOSITORY/IES"

               WRITE !,"R7 Failed!"

               GOTO R8

 +11       WRITE !,"R7 PASSED!!"

 +12      ;

R8        ;

 +1       ;^PS(51.25,67,1,1,0)="APPLICATORFUL/S^1"

 +2       ;RESET APPLICATORFUL(S) to APPLICATORFUL/S

 +3       ;

 +4        NEW DIE,DR,DA

 +5        SET DA=1

           SET DA(1)=67

           SET XUMF=1

 +6        SET DIE="^PS(51.25,DA(1),1,"

           SET DR=".01////"_"APPLICATORFUL/S"

 +7        DO ^DIE

 +8        IF $PIECE($GET(^PS(51.25,67,1,1,0)),U,1)'="APPLICATORFUL/S"

               WRITE !,"R8 Failed!"

               QUIT

 +9        WRITE !,"R8 PASSED!!",!!!

 +10      ;

 +11       QUIT

PSS1P178.m