PSO746PI.m

PSO746PI ;BHAM/MFR - PSO*7*746 POST INSTALL; 10/01/2022 11:24Am

 ;;7.0;OUTPATIENT PHARMACY;**746**;DEC 1997;Build 106

 ;

 ;Reference to $$CRDD^TIUCRDD in ICR #7179

 ;

EN ; Entry Point

 N HOPIEN,RRPIEN,DONE,IEN,CHHOPIEN,XCODE,DIC,X

 D BMES^XPDUTL("Starting post-install for PSO*7*746 at "_$$FMTE^XLFDT($$NOW^XLFDT()))

 ;

 ; New Hold codes

 I '$D(^PS(52.45,"B","HFF")) D

 . S X="HFF",DIC="^PS(52.45,",DIC(0)="",DIC("DR")=".02///HOLD FOR FUTURE FILL;.03///ERX"

 . D FILE^DICN

 ;

 ; Adding template Change Reason Texts to file #52.45

 S CODE="" F  S CODE=$O(^PS(52.45,"TYPE","REA",CODE)) Q:'CODE  D

 . K TEXT,REATXT S XCODE=$$GET1^DIQ(52.45,CODE,.01)

 . I ",DA,DD,HD,LD,MS,TD,AR,DI,DR,ID,UD,PS,SX,TP,"'[(","_XCODE_",") Q

 . K ^PS(52.45,CODE,20)

 . I XCODE="DA" D

 . . S TEXT(1,0)="Pt has a listed allergy to medication/component of medication prescribed"

 . . S TEXT(2,0)="[DRUG_NAME]. Please advise: To fill as is, send denial to this request with"

 . . S TEXT(3,0)="note stating reason fill is acceptable. If med should not be filled, Cancel Rx"

 . . S TEXT(4,0)="and send replacement."

 . I XCODE="DD" D

 . . S TEXT(1,0)="eRx drug interacts with [DRUG_NAME]. Please advise: To fill this medication,"

 . . S TEXT(2,0)="send denial with note stating pt requires both medications or note that"

 . . S TEXT(3,0)="[DRUG_NAME] should be canceled. If med should not be filled, Cancel RX and send"

 . . S TEXT(4,0)="replacement."

 . I XCODE="HD" D

 . . S TEXT(1,0)="The prescribed dosage exceeds typical maximum. Please advise: To fill as is,"

 . . S TEXT(2,0)="send denial to this request with note stating reason fill is acceptable. To"

 . . S TEXT(3,0)="fill within manufacturer guidelines, approve recommendation below."

 . I XCODE="LD" D

 . . S TEXT(1,0)="The prescribed dosage is below typical minimum. Please advise: To fill as is,"

 . . S TEXT(2,0)="send denial to this request with note stating reason fill is acceptable. To fill"

 . . S TEXT(3,0)="within manufacturer guidelines, approve recommendation below."

 . I XCODE="MS" D

 . . S TEXT(1,0)="The eRx is missing or unclear on [ADD_TEXT_HERE], Please edit and respond or"

 . . S TEXT(2,0)="cancel Rx and send a new prescription with the requested information."

 . I XCODE="TD" D

 . . S TEXT(1,0)="Pt has medication of the same class/indication/drug on file. To fill this Rx,"

 . . S TEXT(2,0)="send denial with note stating pt requires both medications or note that"

 . . S TEXT(3,0)="[DRUG_NAME] should be canceled. If this med should not be filled, Cancel RX and"

 . . S TEXT(4,0)="send a replacement."

 . I XCODE="AR" D

 . . S TEXT(1,0)="Patient has an adverse drug reaction to medication/component of medication"

 . . S TEXT(2,0)="prescribed. To fill as is, send denial to this request with note stating reason"

 . . S TEXT(3,0)="fill is acceptable. If med should not be filled- Cancel RX and send a"

 . . S TEXT(4,0)="replacement."

 . I XCODE="DI" D

 . . S TEXT(1,0)="eRx drug is incompatible with [DRUG_NAME]. To fill this Rx, send denial with"

 . . S TEXT(2,0)="note stating pt requires both medications or note that [DRUG_NAME] should be"

 . . S TEXT(3,0)="canceled. If med should not be filled, Cancel RX and send a replacement."

 . I XCODE="DR" D

 . . S TEXT(1,0)="The prescribed dosage does not align with manufacturer recommendations. Please"

 . . S TEXT(2,0)="advise: To fill as is, send denial to this request with note stating reason fill"

 . . S TEXT(3,0)="is acceptable. To fill within manufacturer guidelines, approve recommendation"

 . . S TEXT(4,0)="below."

 . I XCODE="ID" D

 . . S TEXT(1,0)="Pt has medication containing the same ingredient on file. To fill this Rx, send"

 . . S TEXT(2,0)="denial with note stating pt requires both medications or note that [DRUG_NAME]"

 . . S TEXT(3,0)="should be canceled. If med should not be filled-Cancel RX and send a"

 . . S TEXT(4,0)="replacement."

 . I XCODE="UD" D

 . . S TEXT(1,0)="Pt has multiple prescriptions for the same drug and strength on file. To fulfill"

 . . S TEXT(2,0)="both Rx, send one Rx containing total qty/directions etc. To fill only this Rx,"

 . . S TEXT(3,0)="send denial with note stating other should be canceled. If med should not be"

 . . S TEXT(4,0)="filled, Cancel Rx."

 . I XCODE="PS" D

 . . S TEXT(1,0)="Pharmacy is unable to supply medication as prescribed; however, alternative"

 . . S TEXT(2,0)="options may exist. Please approve an option below or Cancel Rx and send a"

 . . S TEXT(3,0)="replacement."

 . I XCODE="SX" D

 . . S TEXT(1,0)="The prescribed medication does not align with manufacturer recommendations based"

 . . S TEXT(2,0)="on patient sex assigned at birth. The pharmacy is unable to fill the medication"

 . . S TEXT(3,0)="as prescribed. Pt may obtain locally at usual cash price."

 . I XCODE="TP" D

 . . S TEXT(1,0)="Prior to processing this medication/class the pharmacy is required to obtain a"

 . . S TEXT(2,0)="diagnosis code. Please edit and respond or Cancel Rx and send a new prescription"

 . . S TEXT(3,0)="with the requested information."

 . S REATXT(52.45,CODE_",",20)="TEXT"

 . K DIERR D UPDATE^DIE("","REATXT")

 ;

 S CODE=$O(^PS(52.45,"D","Script Clarification",0))

 I CODE D

 . K ^PS(52.45,CODE,20)

 . K TEXT,REATXT

 . S TEXT(1,0)="The eRx is missing or unclear on [ADD_TEXT_HERE], Please edit and respond or"

 . S TEXT(2,0)="cancel Rx and send a new prescription with the requested information."

 . S REATXT(52.45,CODE_",",20)="TEXT"

 . K DIERR D UPDATE^DIE("","REATXT")

 ; 

 S CODE=$O(^PS(52.45,"D","Therapeutic Interchange/Substi",0))

 I CODE D

 . K ^PS(52.45,CODE,20)

 . K TEXT,REATXT

 . S TEXT(1,0)="Pharmacy is unable to supply medication as prescribed; however, alternative"

 . S TEXT(2,0)="options may exist. Please approve an option below or Cancel Rx and send a"

 . S TEXT(3,0)="replacement."

 . S REATXT(52.45,CODE_",",20)="TEXT"

 . K DIERR D UPDATE^DIE("","REATXT")

 ;

 S CODE=$O(^PS(52.45,"D","Generic Substitution",0))

 I CODE D

 . K ^PS(52.45,CODE,20)

 . K TEXT,REATXT

 . S TEXT(1,0)="Rx received was marked Dispense as Written however Brand Name product is not"

 . S TEXT(2,0)="available to be dispensed. Please approve generic substitution option below or"

 . S TEXT(3,0)="send replacement Rx."

 . S REATXT(52.45,CODE_",",20)="TEXT"

 . K DIERR D UPDATE^DIE("","REATXT")

 ;

 S CODE=$O(^PS(52.45,"D","Prescribed with acknowledgemen",0))

 I CODE D

 . N DIE S DIE="^PS(52.45,",DA=CODE,DR=".02///Prescribed w/ acknowledgements" D ^DIE

 ;

 S CODE=$O(^PS(52.45,"D","Out of Stock",0))

 I CODE D

 . K ^PS(52.45,CODE,20)

 . K TEXT,REATXT

 . S TEXT(1,0)="The medication prescribed is currently out of stock, if a substitutable product"

 . S TEXT(2,0)="exists and is presented as an option below, it may be approved. Otherwise, pt"

 . S TEXT(3,0)="may need to obtain locally or have replacement product prescribed."

 . S REATXT(52.45,CODE_",",20)="TEXT"

 . K DIERR D UPDATE^DIE("","REATXT")

 ;

 D CREATEPN("PHARMACY SERVICE","PHARMACY PROGRESS NOTE","ERX RX CHANGE REQUEST NOTE") ;create new eRx Progress Notes Title in File #8925.1

 ;

 ; Killing and Re-Building "ADRGVRX" x-reference

 I $$GET1^DIQ(59.7,1,102,"I")'="MBM" D

 . D BMES^XPDUTL("Re-building Drug Suggestion x-reference... "_$$FMTE^XLFDT($$NOW^XLFDT()))

 . K ^PS(52.49,"ADRGVRX") S DIK="^PS(52.49,",DIK(1)=".13^ADRGVRX" D ENALL^DIK

 ;

 ; Updating Protocol Headers to display eRx Meds on File in Backdoor Pharmacy

 N ORDIEN

 S ORDIEN=$O(^ORD(101,"B","PSO LM PAT INFO MENU",0))

 I ORDIEN S ^ORD(101,ORDIEN,26)="D SHOW^VALM,NVAERX^PSOORUT2"

 S ORDIEN=$O(^ORD(101,"B","PSO LM MEDICATION PROFILE",0))

 I ORDIEN S ^ORD(101,ORDIEN,26)="D A^PSOORUT3,SHOW^VALM S XQORM(""#"")=$O(^ORD(101,""B"",""PSO LM NEW SELECT ORDER"",0))_""^1:""_$S($G(PSORCNT):PSORCNT,1:PSOCNT) D NVAERX^PSOORUT2"

 ;

 D BMES^XPDUTL("Post-install for PSO*7*746 completed successfully at "_$$FMTE^XLFDT($$NOW^XLFDT()))

 Q

 ;

CREATEPN(PARNTDOC,STDTITLE,TITLE) ;

 ;Input: PARNTDOC - Name of the desired parent in File #8925.1

 ;       STDTITLE - Name of the VHA Enterprise Standard Title in File #8926.1

 ;       TITLE    - Name of the desired title in File #8925.1

 ;Output: Create a new entry TIU NOTE Title in File #8925.1

 ;

 N FOUNDDOC,FOUNDSTD,MES,RESULT

 ;check parent document class PHARMACY SERVICE

 S FOUNDDOC=$$FIND1^DIC(8925.1,"","X",PARNTDOC,"B")

 ;

 ; check VHA Enterprise Standard Title PHARMACY PROGRESS NOTE

 S FOUNDSTD=$$FIND1^DIC(8926.1,"","X",STDTITLE,"B")

 ;

 S MES(1)=""

 ;if PHARMACY SERVICE and PHARMACY PROGRESS NOTE exist, attach and map the new ERX RX CHANGE REQUEST NOTE TIU Note Title

 I +FOUNDDOC,+FOUNDSTD D  Q

 . S RESULT=$$CRDD^TIUCRDD(TITLE,"DOC","ACTIVE",PARNTDOC,STDTITLE)

 . I '+RESULT D  Q

 . . S MES(2)=$S(RESULT["already exists":$P(RESULT,U,2)_" No action taken.",1:"Installation Error: "_$P(RESULT,U,2))

 . . S MES(3)=""

 . . D MES^XPDUTL(.MES)

 . S MES(2)="Successfully created "_TITLE_" in File #8925.1."

 . S MES(3)=""

 . D MES^XPDUTL(.MES)

 ;

 ;Otherwise, do not attach and map the new ERX RX REQUEST NOTE TIU Note Title

 S MES(2)="Installation Error:"

 S MES(3)="    The creation of the ERX RX CHANGE REQUEST NOTE TIU Title failed."

 ;

 I '+FOUNDDOC,'+FOUNDSTD D  ;both parent doc class and std title does not exist at the site

 . S MES(4)="       * "_PARNTDOC_" Document Class not found."

 . S MES(5)="       * VHA Enterprise Standard Title "_STDTITLE_" not found."

 . S MES(6)=""

 ;

 I '+FOUNDDOC,+FOUNDSTD D  ;std title exist but parent doc class does not exist at the site

 . S MES(4)="       * "_PARNTDOC_" Document Class not found."

 . S MES(5)=""

 ;

 I +FOUNDDOC,'+FOUNDSTD D  ;parent doc exist but std title does not exist at the site

 . S MES(4)="       * VHA Enterprise Standard Title "_STDTITLE_" not found."

 . S MES(5)=""

 ;

 D MES^XPDUTL(.MES)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSO746PI   9903     printed  Mar 13, 2025@21:28:28                                                                                                                                                                                                    Page 2

PSO746PI  ;BHAM/MFR - PSO*7*746 POST INSTALL; 10/01/2022 11:24Am

 +1       ;;7.0;OUTPATIENT PHARMACY;**746**;DEC 1997;Build 106

 +2       ;

 +3       ;Reference to $$CRDD^TIUCRDD in ICR #7179

 +4       ;

EN        ; Entry Point

 +1        NEW HOPIEN,RRPIEN,DONE,IEN,CHHOPIEN,XCODE,DIC,X

 +2        DO BMES^XPDUTL("Starting post-install for PSO*7*746 at "_$$FMTE^XLFDT($$NOW^XLFDT()))

 +3       ;

 +4       ; New Hold codes

 +5        IF '$DATA(^PS(52.45,"B","HFF"))

               Begin DoDot:1

 +6                SET X="HFF"

                   SET DIC="^PS(52.45,"

                   SET DIC(0)=""

                   SET DIC("DR")=".02///HOLD FOR FUTURE FILL;.03///ERX"

 +7                DO FILE^DICN

               End DoDot:1

 +8       ;

 +9       ; Adding template Change Reason Texts to file #52.45

 +10       SET CODE=""

           FOR 

               SET CODE=$ORDER(^PS(52.45,"TYPE","REA",CODE))

               if 'CODE

                   QUIT 

               Begin DoDot:1

 +11               KILL TEXT,REATXT

                   SET XCODE=$$GET1^DIQ(52.45,CODE,.01)

 +12               IF ",DA,DD,HD,LD,MS,TD,AR,DI,DR,ID,UD,PS,SX,TP,"'[(","_XCODE_",")

                       QUIT 

 +13               KILL ^PS(52.45,CODE,20)

 +14               IF XCODE="DA"

                       Begin DoDot:2

 +15                       SET TEXT(1,0)="Pt has a listed allergy to medication/component of medication prescribed"

 +16                       SET TEXT(2,0)="[DRUG_NAME]. Please advise: To fill as is, send denial to this request with"

 +17                       SET TEXT(3,0)="note stating reason fill is acceptable. If med should not be filled, Cancel Rx"

 +18                       SET TEXT(4,0)="and send replacement."

                       End DoDot:2

 +19               IF XCODE="DD"

                       Begin DoDot:2

 +20                       SET TEXT(1,0)="eRx drug interacts with [DRUG_NAME]. Please advise: To fill this medication,"

 +21                       SET TEXT(2,0)="send denial with note stating pt requires both medications or note that"

 +22                       SET TEXT(3,0)="[DRUG_NAME] should be canceled. If med should not be filled, Cancel RX and send"

 +23                       SET TEXT(4,0)="replacement."

                       End DoDot:2

 +24               IF XCODE="HD"

                       Begin DoDot:2

 +25                       SET TEXT(1,0)="The prescribed dosage exceeds typical maximum. Please advise: To fill as is,"

 +26                       SET TEXT(2,0)="send denial to this request with note stating reason fill is acceptable. To"

 +27                       SET TEXT(3,0)="fill within manufacturer guidelines, approve recommendation below."

                       End DoDot:2

 +28               IF XCODE="LD"

                       Begin DoDot:2

 +29                       SET TEXT(1,0)="The prescribed dosage is below typical minimum. Please advise: To fill as is,"

 +30                       SET TEXT(2,0)="send denial to this request with note stating reason fill is acceptable. To fill"

 +31                       SET TEXT(3,0)="within manufacturer guidelines, approve recommendation below."

                       End DoDot:2

 +32               IF XCODE="MS"

                       Begin DoDot:2

 +33                       SET TEXT(1,0)="The eRx is missing or unclear on [ADD_TEXT_HERE], Please edit and respond or"

 +34                       SET TEXT(2,0)="cancel Rx and send a new prescription with the requested information."

                       End DoDot:2

 +35               IF XCODE="TD"

                       Begin DoDot:2

 +36                       SET TEXT(1,0)="Pt has medication of the same class/indication/drug on file. To fill this Rx,"

 +37                       SET TEXT(2,0)="send denial with note stating pt requires both medications or note that"

 +38                       SET TEXT(3,0)="[DRUG_NAME] should be canceled. If this med should not be filled, Cancel RX and"

 +39                       SET TEXT(4,0)="send a replacement."

                       End DoDot:2

 +40               IF XCODE="AR"

                       Begin DoDot:2

 +41                       SET TEXT(1,0)="Patient has an adverse drug reaction to medication/component of medication"

 +42                       SET TEXT(2,0)="prescribed. To fill as is, send denial to this request with note stating reason"

 +43                       SET TEXT(3,0)="fill is acceptable. If med should not be filled- Cancel RX and send a"

 +44                       SET TEXT(4,0)="replacement."

                       End DoDot:2

 +45               IF XCODE="DI"

                       Begin DoDot:2

 +46                       SET TEXT(1,0)="eRx drug is incompatible with [DRUG_NAME]. To fill this Rx, send denial with"

 +47                       SET TEXT(2,0)="note stating pt requires both medications or note that [DRUG_NAME] should be"

 +48                       SET TEXT(3,0)="canceled. If med should not be filled, Cancel RX and send a replacement."

                       End DoDot:2

 +49               IF XCODE="DR"

                       Begin DoDot:2

 +50                       SET TEXT(1,0)="The prescribed dosage does not align with manufacturer recommendations. Please"

 +51                       SET TEXT(2,0)="advise: To fill as is, send denial to this request with note stating reason fill"

 +52                       SET TEXT(3,0)="is acceptable. To fill within manufacturer guidelines, approve recommendation"

 +53                       SET TEXT(4,0)="below."

                       End DoDot:2

 +54               IF XCODE="ID"

                       Begin DoDot:2

 +55                       SET TEXT(1,0)="Pt has medication containing the same ingredient on file. To fill this Rx, send"

 +56                       SET TEXT(2,0)="denial with note stating pt requires both medications or note that [DRUG_NAME]"

 +57                       SET TEXT(3,0)="should be canceled. If med should not be filled-Cancel RX and send a"

 +58                       SET TEXT(4,0)="replacement."

                       End DoDot:2

 +59               IF XCODE="UD"

                       Begin DoDot:2

 +60                       SET TEXT(1,0)="Pt has multiple prescriptions for the same drug and strength on file. To fulfill"

 +61                       SET TEXT(2,0)="both Rx, send one Rx containing total qty/directions etc. To fill only this Rx,"

 +62                       SET TEXT(3,0)="send denial with note stating other should be canceled. If med should not be"

 +63                       SET TEXT(4,0)="filled, Cancel Rx."

                       End DoDot:2

 +64               IF XCODE="PS"

                       Begin DoDot:2

 +65                       SET TEXT(1,0)="Pharmacy is unable to supply medication as prescribed; however, alternative"

 +66                       SET TEXT(2,0)="options may exist. Please approve an option below or Cancel Rx and send a"

 +67                       SET TEXT(3,0)="replacement."

                       End DoDot:2

 +68               IF XCODE="SX"

                       Begin DoDot:2

 +69                       SET TEXT(1,0)="The prescribed medication does not align with manufacturer recommendations based"

 +70                       SET TEXT(2,0)="on patient sex assigned at birth. The pharmacy is unable to fill the medication"

 +71                       SET TEXT(3,0)="as prescribed. Pt may obtain locally at usual cash price."

                       End DoDot:2

 +72               IF XCODE="TP"

                       Begin DoDot:2

 +73                       SET TEXT(1,0)="Prior to processing this medication/class the pharmacy is required to obtain a"

 +74                       SET TEXT(2,0)="diagnosis code. Please edit and respond or Cancel Rx and send a new prescription"

 +75                       SET TEXT(3,0)="with the requested information."

                       End DoDot:2

 +76               SET REATXT(52.45,CODE_",",20)="TEXT"

 +77               KILL DIERR

                   DO UPDATE^DIE("","REATXT")

               End DoDot:1

 +78      ;

 +79       SET CODE=$ORDER(^PS(52.45,"D","Script Clarification",0))

 +80       IF CODE

               Begin DoDot:1

 +81               KILL ^PS(52.45,CODE,20)

 +82               KILL TEXT,REATXT

 +83               SET TEXT(1,0)="The eRx is missing or unclear on [ADD_TEXT_HERE], Please edit and respond or"

 +84               SET TEXT(2,0)="cancel Rx and send a new prescription with the requested information."

 +85               SET REATXT(52.45,CODE_",",20)="TEXT"

 +86               KILL DIERR

                   DO UPDATE^DIE("","REATXT")

               End DoDot:1

 +87      ; 

 +88       SET CODE=$ORDER(^PS(52.45,"D","Therapeutic Interchange/Substi",0))

 +89       IF CODE

               Begin DoDot:1

 +90               KILL ^PS(52.45,CODE,20)

 +91               KILL TEXT,REATXT

 +92               SET TEXT(1,0)="Pharmacy is unable to supply medication as prescribed; however, alternative"

 +93               SET TEXT(2,0)="options may exist. Please approve an option below or Cancel Rx and send a"

 +94               SET TEXT(3,0)="replacement."

 +95               SET REATXT(52.45,CODE_",",20)="TEXT"

 +96               KILL DIERR

                   DO UPDATE^DIE("","REATXT")

               End DoDot:1

 +97      ;

 +98       SET CODE=$ORDER(^PS(52.45,"D","Generic Substitution",0))

 +99       IF CODE

               Begin DoDot:1

 +100              KILL ^PS(52.45,CODE,20)

 +101              KILL TEXT,REATXT

 +102              SET TEXT(1,0)="Rx received was marked Dispense as Written however Brand Name product is not"

 +103              SET TEXT(2,0)="available to be dispensed. Please approve generic substitution option below or"

 +104              SET TEXT(3,0)="send replacement Rx."

 +105              SET REATXT(52.45,CODE_",",20)="TEXT"

 +106              KILL DIERR

                   DO UPDATE^DIE("","REATXT")

               End DoDot:1

 +107     ;

 +108      SET CODE=$ORDER(^PS(52.45,"D","Prescribed with acknowledgemen",0))

 +109      IF CODE

               Begin DoDot:1

 +110              NEW DIE

                   SET DIE="^PS(52.45,"

                   SET DA=CODE

                   SET DR=".02///Prescribed w/ acknowledgements"

                   DO ^DIE

               End DoDot:1

 +111     ;

 +112      SET CODE=$ORDER(^PS(52.45,"D","Out of Stock",0))

 +113      IF CODE

               Begin DoDot:1

 +114              KILL ^PS(52.45,CODE,20)

 +115              KILL TEXT,REATXT

 +116              SET TEXT(1,0)="The medication prescribed is currently out of stock, if a substitutable product"

 +117              SET TEXT(2,0)="exists and is presented as an option below, it may be approved. Otherwise, pt"

 +118              SET TEXT(3,0)="may need to obtain locally or have replacement product prescribed."

 +119              SET REATXT(52.45,CODE_",",20)="TEXT"

 +120              KILL DIERR

                   DO UPDATE^DIE("","REATXT")

               End DoDot:1

 +121     ;

 +122     ;create new eRx Progress Notes Title in File #8925.1

           DO CREATEPN("PHARMACY SERVICE","PHARMACY PROGRESS NOTE","ERX RX CHANGE REQUEST NOTE")

 +123     ;

 +124     ; Killing and Re-Building "ADRGVRX" x-reference

 +125      IF $$GET1^DIQ(59.7,1,102,"I")'="MBM"

               Begin DoDot:1

 +126              DO BMES^XPDUTL("Re-building Drug Suggestion x-reference... "_$$FMTE^XLFDT($$NOW^XLFDT()))

 +127              KILL ^PS(52.49,"ADRGVRX")

                   SET DIK="^PS(52.49,"

                   SET DIK(1)=".13^ADRGVRX"

                   DO ENALL^DIK

               End DoDot:1

 +128     ;

 +129     ; Updating Protocol Headers to display eRx Meds on File in Backdoor Pharmacy

 +130      NEW ORDIEN

 +131      SET ORDIEN=$ORDER(^ORD(101,"B","PSO LM PAT INFO MENU",0))

 +132      IF ORDIEN

               SET ^ORD(101,ORDIEN,26)="D SHOW^VALM,NVAERX^PSOORUT2"

 +133      SET ORDIEN=$ORDER(^ORD(101,"B","PSO LM MEDICATION PROFILE",0))

 +134      IF ORDIEN

               SET ^ORD(101,ORDIEN,26)="D A^PSOORUT3,SHOW^VALM S XQORM(""#"")=$O(^ORD(101,""B"",""PSO LM NEW SELECT ORDER"",0))_""^1:""_$S($G(PSORCNT):PSORCNT,1:PSOCNT) D NVAERX^PSOORUT2"

 +135     ;

 +136      DO BMES^XPDUTL("Post-install for PSO*7*746 completed successfully at "_$$FMTE^XLFDT($$NOW^XLFDT()))

 +137      QUIT 

 +138     ;

CREATEPN(PARNTDOC,STDTITLE,TITLE) ;

 +1       ;Input: PARNTDOC - Name of the desired parent in File #8925.1

 +2       ;       STDTITLE - Name of the VHA Enterprise Standard Title in File #8926.1

 +3       ;       TITLE    - Name of the desired title in File #8925.1

 +4       ;Output: Create a new entry TIU NOTE Title in File #8925.1

 +5       ;

 +6        NEW FOUNDDOC,FOUNDSTD,MES,RESULT

 +7       ;check parent document class PHARMACY SERVICE

 +8        SET FOUNDDOC=$$FIND1^DIC(8925.1,"","X",PARNTDOC,"B")

 +9       ;

 +10      ; check VHA Enterprise Standard Title PHARMACY PROGRESS NOTE

 +11       SET FOUNDSTD=$$FIND1^DIC(8926.1,"","X",STDTITLE,"B")

 +12      ;

 +13       SET MES(1)=""

 +14      ;if PHARMACY SERVICE and PHARMACY PROGRESS NOTE exist, attach and map the new ERX RX CHANGE REQUEST NOTE TIU Note Title

 +15       IF +FOUNDDOC

               IF +FOUNDSTD

                   Begin DoDot:1

 +16                   SET RESULT=$$CRDD^TIUCRDD(TITLE,"DOC","ACTIVE",PARNTDOC,STDTITLE)

 +17                   IF '+RESULT

                           Begin DoDot:2

 +18                           SET MES(2)=$SELECT(RESULT["already exists":$PIECE(RESULT,U,2)_" No action taken.",1:"Installation Error: "_$PIECE(RESULT,U,2))

 +19                           SET MES(3)=""

 +20                           DO MES^XPDUTL(.MES)

                           End DoDot:2

                           QUIT 

 +21                   SET MES(2)="Successfully created "_TITLE_" in File #8925.1."

 +22                   SET MES(3)=""

 +23                   DO MES^XPDUTL(.MES)

                   End DoDot:1

                   QUIT 

 +24      ;

 +25      ;Otherwise, do not attach and map the new ERX RX REQUEST NOTE TIU Note Title

 +26       SET MES(2)="Installation Error:"

 +27       SET MES(3)="    The creation of the ERX RX CHANGE REQUEST NOTE TIU Title failed."

 +28      ;

 +29      ;both parent doc class and std title does not exist at the site

           IF '+FOUNDDOC

               IF '+FOUNDSTD

                   Begin DoDot:1

 +30                   SET MES(4)="       * "_PARNTDOC_" Document Class not found."

 +31                   SET MES(5)="       * VHA Enterprise Standard Title "_STDTITLE_" not found."

 +32                   SET MES(6)=""

                   End DoDot:1

 +33      ;

 +34      ;std title exist but parent doc class does not exist at the site

           IF '+FOUNDDOC

               IF +FOUNDSTD

                   Begin DoDot:1

 +35                   SET MES(4)="       * "_PARNTDOC_" Document Class not found."

 +36                   SET MES(5)=""

                   End DoDot:1

 +37      ;

 +38      ;parent doc exist but std title does not exist at the site

           IF +FOUNDDOC

               IF '+FOUNDSTD

                   Begin DoDot:1

 +39                   SET MES(4)="       * VHA Enterprise Standard Title "_STDTITLE_" not found."

 +40                   SET MES(5)=""

                   End DoDot:1

 +41      ;

 +42       DO MES^XPDUTL(.MES)

 +43       QUIT