Routine: PSOCPC

PSOCPC ;BHAM ISC/BAB - PHARMACY CO-PAY APPLICATION ;06/09/92

 ;;7.0;OUTPATIENT PHARMACY;**10,9,71,85,114,157,143,239,201,275,225,495**;DEC 1997;Build 9

 ;REF/IA

 ;piece 9 of zero node of File 350 and APDT cross reference of File 350/2215

 ;$$STATUS^IBARX/125

 ;File 350.1/592 (DBIA125-B)

WARN ; Message when attempt is made to delete a refill date on COPAY

 N PSOIB,PSOIBST

 S PSOFLG=0

 G:'$D(^PSRX(DA(1),1,DA,"IB")) ENDW

 S PSOIB=^PSRX(DA(1),1,DA,"IB")

 I +PSOIB'>0 G ENDW

 S PSOIBST=$$STATUS^IBARX(+PSOIB) I PSOIBST=2!(PSOIBST=0) G ENDW

 I +PSOIB>0 D CANCEL G ENDW:PSOFLG=0

 I '$G(PSOXXDEL) D EN^DDIOL("This REFILL has COPAY charges, which MUST be removed","","$C(7),!!"),EN^DDIOL("BEFORE the refill date is deleted.","","!")

 I '$G(PSOXXDEL) D EN^DDIOL("Use option RESET COPAY STATUS/CANCEL CHARGES, return to EDIT A PRESCRIPTION,","","!!"),EN^DDIOL("and delete the refill date.","","!"),EN^DDIOL(" ","","!!")

 S PSOFLG=1

ENDW ;

 I PSOFLG

 K PSOFLG

CANCEL ;Check if charge is cancelled for this Refill date

 S PSOFLG=1 ;indicates a charge not cancelled

 S PSOX=+^PSRX(DA(1),1,DA,"IB")

 D LAST I PSOLAST'=PSOPARNT,$D(^IB(PSOLAST,0)),$P(^IBE(350.1,$P(^IB(PSOLAST,0),"^",3),0),"^",5)=2 S PSOFLG=0

 K PSOLAST,PSOPARNT,PSOX,PSOL,PSOLDT

LAST ;find last entry

 S PSOLAST=""

 S PSOPARNT=$P(^IB(+PSOX,0),"^",9) I 'PSOPARNT S PSOPARNT=+PSOX

 S PSOLDT=$O(^IB("APDT",PSOPARNT,"")) I +PSOLDT F PSOL=0:0 S PSOL=$O(^IB("APDT",PSOPARNT,PSOLDT,PSOL)) Q:'PSOL  S PSOLAST=PSOL

 I PSOLAST="" S PSOLAST=PSOPARNT

EXEMCHK ; Allow reset of exemption answers

 N PSOTG,PSOCPN,PSOEXMT,PSOANS,OLDIBQ,PSOSCP,PSOSCA

 S PSOANS=0 D SCP^PSORN52D

 S OLDIBQ=$G(^PSRX(PSODA,"IBQ"))

 I OLDIBQ[0!(OLDIBQ)[1 D

 . S PSOANS=1

 . I $P(OLDIBQ,"^",1)'="" S PSOTG("SC")=$P(OLDIBQ,"^",1)

 . I $P(OLDIBQ,"^",2)'="" S PSOTG("MST")=$P(OLDIBQ,"^",2)

 . I $P(OLDIBQ,"^",3)'="" S PSOTG("AO")=$P(OLDIBQ,"^",3)

 . I $P(OLDIBQ,"^",4)'="" S PSOTG("IR")=$P(OLDIBQ,"^",4)

 . I $P(OLDIBQ,"^",5)'="" S PSOTG("EC")=$P(OLDIBQ,"^",5)

 . I $P(OLDIBQ,"^",6)'="" S PSOTG("HNC")=$P(OLDIBQ,"^",6)

 . I $P(OLDIBQ,"^",7)'="" S PSOTG("CV")=$P(OLDIBQ,"^",7)

 . I $P(OLDIBQ,"^",8)'="" S PSOTG("SHAD")=$P(OLDIBQ,"^",8)

 S PSOCPN=$P(^PSRX(PSODA,0),"^",2)

 S RXP=PSODA

 D SCNEW^PSOCP(.PSOTG,PSOCPN,"",PSODA)

 N EXMT

 D XTYPE^PSOCP ; KEEP THIS CALL IN HERE TO SEE IF SC QUESTION APPLIES

 ;I $D(PSOTG("SC")) S PSOTG("SC")=$P(OLDIBQ,"^",1) ; CHANGED TO JUST USE IBQ SETTING IF SC QUESTION APPLIES - DON'T RE-CALCULATE SERVICE-CONNECTED

 S EXMT="" F  S EXMT=$O(PSOTG(EXMT)) Q:EXMT=""  I PSOTG(EXMT)'="" S PSOANS=1 Q

 I $O(PSOTG(""))="" Q

 I PSOANS W !!,"The following exemption flags have been set:"

 F EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC" I $G(PSOTG(EXMT))'="" W !,$S(EXMT="EC":"SWAC",1:EXMT),": ",?6,$S(PSOTG(EXMT)=1:"Yes",PSOTG(EXMT)=0:"No",1:"")

W !

 W ! K DIR S DIR(0)="Y",DIR("B")="N" D  S DIR("A")="Do you want to enter/edit any copay exemption flags"

 . S EXMT="" F  S EXMT=$O(PSOTG(EXMT)) Q:EXMT=""  I PSOTG(EXMT)="" S DIR("B")="Y" Q

 S DIR("?")="Enter 'Y' for Yes if you want to edit any applicable medication exemption flags."

 S DIR("??")="^D HELPEXEM^PSOCPC"

 D ^DIR K DIR S PSOEXMT=Y I Y'=1 Q

 ; PRESENT ALL APPLICABLE EXEMPTIONS AND SAVE NEW ANSWERS

 N PSOIBQ,PSOSUBS,PSOQUES,PSOLTAG,OLDIBQ,II,PSOCHG,PSOPATST

 S PSOPATST=$$GET1^DIQ(52,PSODA_",",3,"I")

 S PSOIBQ=""

 S OLDIBQ=$G(^PSRX(PSODA,"IBQ"))

 I '$D(^PSRX(PSODA,"IBQ")),+($G(^PSRX(PSODA,"IB")))=2 S $P(OLDIBQ,"^",1)=0 ; SC QUESTION WAS PREVIOUSLY ANSWERED AS N

 S PSOCOMM="",PSOOLD="",PSONW=""

 S II=0

 F EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC" I $D(PSOTG(EXMT)) D

 . S PSOLTAG="REL"_EXMT_"^PSOCPE"

 . S HELPTAG="HELP"_EXMT

 . S PSOQUES=$P($T(@PSOLTAG),";",2) I PSOQUES="" Q

 . S PSOQUES=$P(PSOQUES,"?")

 . S PSOSUBS=$P($T(@PSOLTAG),";",3) I PSOSUBS="" Q

 . D ASKEXEM

 I $D(PSOCHG) D

 . ;PSO*7*275 IBQ node should not be present in some cases.

 . K ^PSRX(PSODA,"IBQ")

 . S:PSOSCP<50&($TR(PSOIBQ,"^")'="")&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1) ^PSRX(PSODA,"IBQ")=PSOIBQ

 . D RESET^PSORN52D  ;set SC/EI on ICD node

 . S PSOPFSA=1 ;PFSS-denotes to calling routine that outpatient classifications changed.

 . D EN^PSOHLSN1(PSODA,"XX","","Order edited")

 . I PCOPAY,PSOIBQ["1" D  ; RESET TO NO COPAY

 . . W !,"Editing of exemption flag(s) has resulted in a copay status change.",!,"The status for this Rx will be reset to NO COPAY."

 . . S $P(^PSRX(PSODA,"IB"),"^",1)=""

 . . S PSOREF="",PSOOLD="Copay",PSONW="No Copay",PREA="R" D ACTLOG^PSOCPA

 . . S PSOCOMM="Copay status reset due to exemption flag(s)"

 . . S PSI=0 D SETSUMM

 . I $G(II)>0 D

 . . S PSOCOMM="The following exemption flags have been changed: ",PSI=0 D SETSUMM

 . . S II="" F  S II=$O(PSOCHG(II)) Q:II=""  S PSOCOMM=PSOCHG(II),PSI=0 D SETSUMM

ASKEXEM ; ASK THE EXEMPTION QUESTIONS

 K DIR S DIR("A")=PSOQUES,DIR(0)="YO" S:PSOTG(EXMT)=1 DIR("B")="Y" S:PSOTG(EXMT)=0 DIR("B")="N" D @HELPTAG

ASKEXEM1 D ^DIR I X="@" R !,"  Are you sure you want to delete this answer? ",X:DTIME I $E(X)'="Y",$E(X)'="y" G ASKEXEM1

 I X="^"!($D(DTOUT)) S X=$G(DIR("B")) S Y=$S(X="Y":1,X="N":0,1:"")

 S $P(PSOIBQ,"^",PSOSUBS)=$S(Y=1:1,Y=0:0,1:"")

 I Y'=PSOTG(EXMT) S II=II+1,PSOCHG(II)=$S(EXMT="EC":"SWAC",1:EXMT)_": "_$S($P(PSOIBQ,"^",PSOSUBS)=1:"Yes",$P(PSOIBQ,"^",PSOSUBS)=0:"No",1:"")

 I Y=1 D

 . I PSOCOMM'="" Q

 . D SETCOMM^PSOCP

HELPEXEM ; help text for exemption edit question

 W !,"Enter 'Y' for Yes if you want to edit any applicable exemption flags such as"

 W !,"Service Connected (SC), Combat Veteran(CV), Agent Orange (AO), Ionizing"

 W !,"Radiation (IR), Southwest Asia Conditions (SWAC), PROJ 112/SHAD,"

 W !,"Military Sexual Trauma (MST), or Head and/or Neck Cancer (HNC)."

HELPSC ;

 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is for a Service Connected condition."

 S DIR("?",2)="This response will be used to determine whether or not a copay should be"

 S DIR("?",3)="applied to the prescription."

HELPAO ;

 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="Vietnam-Era Herbicide (Agent Orange) exposure. This response will be used to"

 S DIR("?",3)="determine whether or not a copay should be applied to the prescription."

HELPIR ;

 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to",DIR("?",2)="ionizing radiation exposure during military service. This response will be used"

 S DIR("?",3)="to determine whether or not a copay should be applied to the prescription."

HELPEC ;

 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related to",DIR("?",2)="service in Southwest Asia. This response will be used to determine whether"

 S DIR("?",3)="or not a copay should be applied to the prescription."

HELPMST ;

 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related",DIR("?",2)="to Military Sexual Trauma. This response will be used to determine whether or"

 S DIR("?",3)="not a copay should be applied to the prescription."

HELPHNC ;

 S DIR("?")=" ",DIR("?",1)="Enter 'Yes' if this prescription is being used to treat Head and/or Neck Cancer",DIR("?",2)="due to nose or throat radium treatments while in the military. This response"

 S DIR("?",3)="will be used to determine whether or not a copay should be applied to the",DIR("?",4)="prescription."

HELPCV ;

 S DIR("?")=" "

 S DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related"

 S DIR("?",2)="to Combat Services. This response will be used to determine whether or"

 S DIR("?",3)="not a copay should be applied to the prescription."

HELPSHAD ;

 S DIR("?")=" "

 S DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related"

 S DIR("?",2)="to PROJ 112/SHAD. This response will be used to determine whether or"

 S DIR("?",3)="not a copay should be applied to the prescription."

SETSUMM ; SET MESSAGE INTO SUMMARY

 S PSI=$O(PSOSUMM(PSI)) G:$O(PSOSUMM(PSI)) SETSUMM

 S PSI=PSI+1,PSOSUMM(PSI)=PSOCOMM

 K PSOCOMM

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCPC   8278     printed  Feb 18, 2025@23:52:17                                                                                                                                                                                                      Page 2

PSOCPC    ;BHAM ISC/BAB - PHARMACY CO-PAY APPLICATION ;06/09/92

 +1       ;;7.0;OUTPATIENT PHARMACY;**10,9,71,85,114,157,143,239,201,275,225,495**;DEC 1997;Build 9

 +2       ;

 +3       ;REF/IA

 +4       ;piece 9 of zero node of File 350 and APDT cross reference of File 350/2215

 +5       ;$$STATUS^IBARX/125

 +6       ;File 350.1/592 (DBIA125-B)

WARN      ; Message when attempt is made to delete a refill date on COPAY

 +1        NEW PSOIB,PSOIBST

 +2        SET PSOFLG=0

 +3        if '$DATA(^PSRX(DA(1),1,DA,"IB"))

               GOTO ENDW

 +4        SET PSOIB=^PSRX(DA(1),1,DA,"IB")

 +5        IF +PSOIB'>0

               GOTO ENDW

 +6        SET PSOIBST=$$STATUS^IBARX(+PSOIB)

           IF PSOIBST=2!(PSOIBST=0)

               GOTO ENDW

 +7        IF +PSOIB>0

               DO CANCEL

               if PSOFLG=0

                   GOTO ENDW

 +8        IF '$GET(PSOXXDEL)

               DO EN^DDIOL("This REFILL has COPAY charges, which MUST be removed","","$C(7),!!")

               DO EN^DDIOL("BEFORE the refill date is deleted.","","!")

 +9        IF '$GET(PSOXXDEL)

               DO EN^DDIOL("Use option RESET COPAY STATUS/CANCEL CHARGES, return to EDIT A PRESCRIPTION,","","!!")

               DO EN^DDIOL("and delete the refill date.","","!")

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

 +10       SET PSOFLG=1

ENDW      ;

 +1        IF PSOFLG

 +2        KILL PSOFLG

 +3        QUIT

CANCEL    ;Check if charge is cancelled for this Refill date

 +1       ;indicates a charge not cancelled

           SET PSOFLG=1

 +2        SET PSOX=+^PSRX(DA(1),1,DA,"IB")

 +3        DO LAST

           IF PSOLAST'=PSOPARNT

               IF $DATA(^IB(PSOLAST,0))

                   IF $PIECE(^IBE(350.1,$PIECE(^IB(PSOLAST,0),"^",3),0),"^",5)=2

                       SET PSOFLG=0

 +4        KILL PSOLAST,PSOPARNT,PSOX,PSOL,PSOLDT

 +5        QUIT

LAST      ;find last entry

 +1        SET PSOLAST=""

 +2        SET PSOPARNT=$PIECE(^IB(+PSOX,0),"^",9)

           IF 'PSOPARNT

               SET PSOPARNT=+PSOX

 +3        SET PSOLDT=$ORDER(^IB("APDT",PSOPARNT,""))

           IF +PSOLDT

               FOR PSOL=0:0

                   SET PSOL=$ORDER(^IB("APDT",PSOPARNT,PSOLDT,PSOL))

                   if 'PSOL

                       QUIT

                   SET PSOLAST=PSOL

 +4        IF PSOLAST=""

               SET PSOLAST=PSOPARNT

 +5        QUIT

 +6       ;

EXEMCHK   ; Allow reset of exemption answers

 +1        NEW PSOTG,PSOCPN,PSOEXMT,PSOANS,OLDIBQ,PSOSCP,PSOSCA

 +2        SET PSOANS=0

           DO SCP^PSORN52D

 +3        SET OLDIBQ=$GET(^PSRX(PSODA,"IBQ"))

 +4        IF OLDIBQ[0!(OLDIBQ)[1

               Begin DoDot:1

 +5                SET PSOANS=1

 +6                IF $PIECE(OLDIBQ,"^",1)'=""

                       SET PSOTG("SC")=$PIECE(OLDIBQ,"^",1)

 +7                IF $PIECE(OLDIBQ,"^",2)'=""

                       SET PSOTG("MST")=$PIECE(OLDIBQ,"^",2)

 +8                IF $PIECE(OLDIBQ,"^",3)'=""

                       SET PSOTG("AO")=$PIECE(OLDIBQ,"^",3)

 +9                IF $PIECE(OLDIBQ,"^",4)'=""

                       SET PSOTG("IR")=$PIECE(OLDIBQ,"^",4)

 +10               IF $PIECE(OLDIBQ,"^",5)'=""

                       SET PSOTG("EC")=$PIECE(OLDIBQ,"^",5)

 +11               IF $PIECE(OLDIBQ,"^",6)'=""

                       SET PSOTG("HNC")=$PIECE(OLDIBQ,"^",6)

 +12               IF $PIECE(OLDIBQ,"^",7)'=""

                       SET PSOTG("CV")=$PIECE(OLDIBQ,"^",7)

 +13               IF $PIECE(OLDIBQ,"^",8)'=""

                       SET PSOTG("SHAD")=$PIECE(OLDIBQ,"^",8)

               End DoDot:1

 +14       SET PSOCPN=$PIECE(^PSRX(PSODA,0),"^",2)

 +15       SET RXP=PSODA

 +16       DO SCNEW^PSOCP(.PSOTG,PSOCPN,"",PSODA)

 +17       NEW EXMT

 +18      ; KEEP THIS CALL IN HERE TO SEE IF SC QUESTION APPLIES

           DO XTYPE^PSOCP

 +19      ;I $D(PSOTG("SC")) S PSOTG("SC")=$P(OLDIBQ,"^",1) ; CHANGED TO JUST USE IBQ SETTING IF SC QUESTION APPLIES - DON'T RE-CALCULATE SERVICE-CONNECTED

 +20       SET EXMT=""

FOR

               SET EXMT=$ORDER(PSOTG(EXMT))

               if EXMT=""

                   QUIT

               IF PSOTG(EXMT)'=""

                   SET PSOANS=1

                   QUIT

 +21       IF $ORDER(PSOTG(""))=""

               QUIT

 +22       IF PSOANS

               WRITE !!,"The following exemption flags have been set:"

 +23       FOR EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC"

               IF $GET(PSOTG(EXMT))'=""

                   WRITE !,$SELECT(EXMT="EC":"SWAC",1:EXMT),": ",?6,$SELECT(PSOTG(EXMT)=1:"Yes",PSOTG(EXMT)=0:"No",1:"")

 +24       WRITE !

 +25       WRITE !

           KILL DIR

           SET DIR(0)="Y"

           SET DIR("B")="N"

           Begin DoDot:1

 +26           SET EXMT=""

FOR

                   SET EXMT=$ORDER(PSOTG(EXMT))

                   if EXMT=""

                       QUIT

                   IF PSOTG(EXMT)=""

                       SET DIR("B")="Y"

                       QUIT

           End DoDot:1

           SET DIR("A")="Do you want to enter/edit any copay exemption flags"

 +27       SET DIR("?")="Enter 'Y' for Yes if you want to edit any applicable medication exemption flags."

 +28       SET DIR("??")="^D HELPEXEM^PSOCPC"

 +29       DO ^DIR

           KILL DIR

           SET PSOEXMT=Y

           IF Y'=1

               QUIT

 +30      ; PRESENT ALL APPLICABLE EXEMPTIONS AND SAVE NEW ANSWERS

 +31       NEW PSOIBQ,PSOSUBS,PSOQUES,PSOLTAG,OLDIBQ,II,PSOCHG,PSOPATST

 +32       SET PSOPATST=$$GET1^DIQ(52,PSODA_",",3,"I")

 +33       SET PSOIBQ=""

 +34       SET OLDIBQ=$GET(^PSRX(PSODA,"IBQ"))

 +35      ; SC QUESTION WAS PREVIOUSLY ANSWERED AS N

           IF '$DATA(^PSRX(PSODA,"IBQ"))

               IF +($GET(^PSRX(PSODA,"IB")))=2

                   SET $PIECE(OLDIBQ,"^",1)=0

 +36       SET PSOCOMM=""

           SET PSOOLD=""

           SET PSONW=""

 +37       SET II=0

 +38       FOR EXMT="SC","CV","AO","IR","EC","SHAD","MST","HNC"

               IF $DATA(PSOTG(EXMT))

                   Begin DoDot:1

 +39                   SET PSOLTAG="REL"_EXMT_"^PSOCPE"

 +40                   SET HELPTAG="HELP"_EXMT

 +41                   SET PSOQUES=$PIECE($TEXT(@PSOLTAG),";",2)

                       IF PSOQUES=""

                           QUIT

 +42                   SET PSOQUES=$PIECE(PSOQUES,"?")

 +43                   SET PSOSUBS=$PIECE($TEXT(@PSOLTAG),";",3)

                       IF PSOSUBS=""

                           QUIT

 +44                   DO ASKEXEM

                   End DoDot:1

 +45       IF $DATA(PSOCHG)

               Begin DoDot:1

 +46      ;PSO*7*275 IBQ node should not be present in some cases.

 +47               KILL ^PSRX(PSODA,"IBQ")

 +48               if PSOSCP<50&($TRANSLATE(PSOIBQ,"^")'="")&($PIECE($GET(^PS(53,+$GET(PSOPATST),0)),"^",7)'=1)

                       SET ^PSRX(PSODA,"IBQ")=PSOIBQ

 +49      ;set SC/EI on ICD node

                   DO RESET^PSORN52D

 +50      ;PFSS-denotes to calling routine that outpatient classifications changed.

                   SET PSOPFSA=1

 +51               DO EN^PSOHLSN1(PSODA,"XX","","Order edited")

 +52      ; RESET TO NO COPAY

                   IF PCOPAY

                       IF PSOIBQ["1"

                           Begin DoDot:2

 +53                           WRITE !,"Editing of exemption flag(s) has resulted in a copay status change.",!,"The status for this Rx will be reset to NO COPAY."

 +54                           SET $PIECE(^PSRX(PSODA,"IB"),"^",1)=""

 +55                           SET PSOREF=""

                               SET PSOOLD="Copay"

                               SET PSONW="No Copay"

                               SET PREA="R"

                               DO ACTLOG^PSOCPA

 +56                           SET PSOCOMM="Copay status reset due to exemption flag(s)"

 +57                           SET PSI=0

                               DO SETSUMM

                           End DoDot:2

 +58               IF $GET(II)>0

                       Begin DoDot:2

 +59                       SET PSOCOMM="The following exemption flags have been changed: "

                           SET PSI=0

                           DO SETSUMM

 +60                       SET II=""

FOR

                               SET II=$ORDER(PSOCHG(II))

                               if II=""

                                   QUIT

                               SET PSOCOMM=PSOCHG(II)

                               SET PSI=0

                               DO SETSUMM

                       End DoDot:2

               End DoDot:1

 +61       QUIT

 +62      ;

ASKEXEM   ; ASK THE EXEMPTION QUESTIONS

 +1        KILL DIR

           SET DIR("A")=PSOQUES

           SET DIR(0)="YO"

           if PSOTG(EXMT)=1

               SET DIR("B")="Y"

           if PSOTG(EXMT)=0

               SET DIR("B")="N"

           DO @HELPTAG

ASKEXEM1   DO ^DIR

           IF X="@"

               READ !,"  Are you sure you want to delete this answer? ",X:DTIME

               IF $EXTRACT(X)'="Y"

                   IF $EXTRACT(X)'="y"

                       GOTO ASKEXEM1

 +1        IF X="^"!($DATA(DTOUT))

               SET X=$GET(DIR("B"))

               SET Y=$SELECT(X="Y":1,X="N":0,1:"")

 +2        SET $PIECE(PSOIBQ,"^",PSOSUBS)=$SELECT(Y=1:1,Y=0:0,1:"")

 +3        IF Y'=PSOTG(EXMT)

               SET II=II+1

               SET PSOCHG(II)=$SELECT(EXMT="EC":"SWAC",1:EXMT)_": "_$SELECT($PIECE(PSOIBQ,"^",PSOSUBS)=1:"Yes",$PIECE(PSOIBQ,"^",PSOSUBS)=0:"No",1:"")

 +4        IF Y=1

               Begin DoDot:1

 +5                IF PSOCOMM'=""

                       QUIT

 +6                DO SETCOMM^PSOCP

               End DoDot:1

 +7        QUIT

 +8       ;

HELPEXEM  ; help text for exemption edit question

 +1        WRITE !,"Enter 'Y' for Yes if you want to edit any applicable exemption flags such as"

 +2        WRITE !,"Service Connected (SC), Combat Veteran(CV), Agent Orange (AO), Ionizing"

 +3        WRITE !,"Radiation (IR), Southwest Asia Conditions (SWAC), PROJ 112/SHAD,"

 +4        WRITE !,"Military Sexual Trauma (MST), or Head and/or Neck Cancer (HNC)."

 +5        QUIT

 +6       ;

HELPSC    ;

 +1        SET DIR("?")=" "

           SET DIR("?",1)="Enter 'Yes' if this prescription is for a Service Connected condition."

 +2        SET DIR("?",2)="This response will be used to determine whether or not a copay should be"

 +3        SET DIR("?",3)="applied to the prescription."

 +4        QUIT

 +5       ;

HELPAO    ;

 +1        SET DIR("?")=" "

           SET DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to"

           SET DIR("?",2)="Vietnam-Era Herbicide (Agent Orange) exposure. This response will be used to"

 +2        SET DIR("?",3)="determine whether or not a copay should be applied to the prescription."

 +3        QUIT

 +4       ;

HELPIR    ;

 +1        SET DIR("?")=" "

           SET DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition due to"

           SET DIR("?",2)="ionizing radiation exposure during military service. This response will be used"

 +2        SET DIR("?",3)="to determine whether or not a copay should be applied to the prescription."

 +3        QUIT

 +4       ;

HELPEC    ;

 +1        SET DIR("?")=" "

           SET DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related to"

           SET DIR("?",2)="service in Southwest Asia. This response will be used to determine whether"

 +2        SET DIR("?",3)="or not a copay should be applied to the prescription."

 +3        QUIT

 +4       ;

HELPMST   ;

 +1        SET DIR("?")=" "

           SET DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related"

           SET DIR("?",2)="to Military Sexual Trauma. This response will be used to determine whether or"

 +2        SET DIR("?",3)="not a copay should be applied to the prescription."

 +3        QUIT

 +4       ;

HELPHNC   ;

 +1        SET DIR("?")=" "

           SET DIR("?",1)="Enter 'Yes' if this prescription is being used to treat Head and/or Neck Cancer"

           SET DIR("?",2)="due to nose or throat radium treatments while in the military. This response"

 +2        SET DIR("?",3)="will be used to determine whether or not a copay should be applied to the"

           SET DIR("?",4)="prescription."

 +3        QUIT

 +4       ;

HELPCV    ;

 +1        SET DIR("?")=" "

 +2        SET DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related"

 +3        SET DIR("?",2)="to Combat Services. This response will be used to determine whether or"

 +4        SET DIR("?",3)="not a copay should be applied to the prescription."

 +5        QUIT

 +6       ;

HELPSHAD  ;

 +1        SET DIR("?")=" "

 +2        SET DIR("?",1)="Enter 'Yes' if this prescription is being used to treat a condition related"

 +3        SET DIR("?",2)="to PROJ 112/SHAD. This response will be used to determine whether or"

 +4        SET DIR("?",3)="not a copay should be applied to the prescription."

 +5        QUIT

SETSUMM   ; SET MESSAGE INTO SUMMARY

 +1        SET PSI=$ORDER(PSOSUMM(PSI))

           if $ORDER(PSOSUMM(PSI))

               GOTO SETSUMM

 +2        SET PSI=PSI+1

           SET PSOSUMM(PSI)=PSOCOMM

 +3        KILL PSOCOMM

 +4        QUIT

 +5       ;

PSOCPC.m