Routine: PX157PST

PX157PST ;ALB/SCK - PX*1.0*157 POST INIT INSTALL

 ;;1.0;PCE PATIENT CARE ENCOUNTER;**157**;Aug 12, 1996

EN ; Edit Education Topics VA-ADVANCE DIRECTIVES & VA-ADVANCED DIRECTIVES SCREENING

 ; -- modifying to "advance directives" terminology.

EN1 ;check VA-ADVANCED DIRECTIVES SCREENING

 S FIX1=0,FIX2=0,IEN1=0,U="^",WD1="VA-ADVANCED DIRECTIVES SCREENING",WD2="Advanced Directive Screening"

 S WD1N="VA-ADVANCE DIRECTIVES SCREENING",WD2N="Advance Directives Screening"

 S WD(1)="determine if the patient should receive Advanced Directive education. "

 S WDN(1)="determine if the patient should receive Advance Directives education."

 S WD(2)="Advanced Directive education.    "

 S WDN(2)="Advance Directives education."

 S IEN1=$O(^AUTTEDT("B",WD1,IEN1)) I IEN1="" G EN2

 S REDT=^AUTTEDT(IEN1,0)

 I $P(REDT,U)'=WD1!($P(REDT,U,4)'=WD2) G EN2

 ;I ^AUTTEDT(IEN1,11,2,0)'=WD(1) G EN2

 ;I ^AUTTEDT(IEN1,12,4,0)'=WD(2) G EN2

SET1 ;SET CORRECT WORDING

 S FIX1=1

 S DA=IEN1,DR=".01////^S X=WD1N",DIE="^AUTTEDT(" D ^DIE

 S DA=IEN1,DR=".04////^S X=WD2N",DIE="^AUTTEDT(" D ^DIE

 S ^AUTTEDT(IEN1,11,2,0)=WDN(1),^AUTTEDT(IEN1,12,4,0)=WDN(2)

EN2 ;check VA-ADVANCED DIRECTIVES

 S IEN2=0,WD1A="VA-ADVANCED DIRECTIVES",WD2A="Advanced Directives"

 S WD1AN="VA-ADVANCE DIRECTIVES",WD2AN="Advance Directives"

 S WDA(1)="The patient and family will identify the implications of advanced"

 S WDA(2)="1.  Explain what an advanced directive is."

 S WDA(3)="2.  Explain the difference between advanced directives and a living will."

 S WDA(4)="5.  Identify a social worker to contact for furthur information as appropriate."

 S WDAN(1)="The patient and family will identify the implications of advance"

 S WDAN(2)="1.  Explain what an advance directives is."

 S WDAN(3)="2.  Explain the difference between advance directives and a living will."

 S WDAN(4)="5.  Identify a social worker to contact for further information as appropriate."

 S IEN2=$O(^AUTTEDT("B",WD1A,IEN2)) I IEN2="" G EN3

 S REDT=^AUTTEDT(IEN2,0)

 I $P(REDT,U)'=WD1A!($P(REDT,U,4)'=WD2A) G EN3

 I ^AUTTEDT(IEN2,11,1,0)'=WDA(1) G EN3

 I ^AUTTEDT(IEN2,12,1,0)'=WDA(2) G EN3

 I ^AUTTEDT(IEN2,12,3,0)'=WDA(3) G EN3

 I ^AUTTEDT(IEN2,12,10,0)'=WDA(4) G EN3

SET2 ;SET CORRECT WORDING

 S FIX2=1

 S DA=IEN2,DR=".01////^S X=WD1AN",DIE="^AUTTEDT(" D ^DIE

 S DA=IEN2,DR=".04////^S X=WD2AN",DIE="^AUTTEDT(" D ^DIE

 S ^AUTTEDT(IEN2,11,1,0)=WDAN(1)

 S ^AUTTEDT(IEN2,12,1,0)=WDAN(2),^AUTTEDT(IEN2,12,3,0)=WDAN(3)

 S ^AUTTEDT(IEN2,12,10,0)=WDAN(4)

EN3 ;MAIL MSG

END ;EXIT PATH

 D MAIL

 K DA,DR,DIE,IEN,IEN1,IEN2,WD,WDN,WDA,WDAN,WD1,WD1N,WD2,WD2N,WD1A,WD1AN,WD2A,WD2AN,FIX1,FIX2,REDT

MAIL ;Send results of Educ Topic fix in a mail message to initiator

 N I,XMSUB,XMTEXT,XMDUZ,XMY,DIFROM

 S XMSUB="Patch PX*1.0*157 Educ topic modification completed"

 S XMDUZ="Patch PX*1.0*157 Educ topic modify job"

 S XMY(.5)="" S:$G(DUZ) XMY(DUZ)=""

 S XMTEXT="^TMP(""PXTXT"",$J,"

 K ^TMP("PXTXT",$J)

 ; set up header and count

 S I=3

 S ^TMP("PXTXT",$J,1)="The modification of Education Topics: VA-Advanced Directives and"

 S ^TMP("PXTXT",$J,2)="VA-Advanced Directives Screening, has completed"

 S ^TMP("PXTXT",$J,I)="",I=I+1

 S ^TMP("PXTXT",$J,I)=""

 I FIX1=0 D

 . S I=I+1,^TMP("PXTXT",$J,I)="                 *** ERROR ALERT ***"

 . S I=I+1,^TMP("PXTXT",$J,I)="Could NOT fix topic VA-Advanced Directives Screening, data did NOT "

 . S I=I+1,^TMP("PXTXT",$J,I)="match national data base"

 I FIX1>0 D

 . S I=I+1,^TMP("PXTXT",$J,I)="                 ***  CHANGED  ***"

 . S I=I+1,^TMP("PXTXT",$J,I)="Modified topic VA-Advanced Directives Screening for verbiage"

 . S I=I+1,^TMP("PXTXT",$J,I)="correction where used"

 S I=I+1,^TMP("PXTXT",$J,I)=""

 I FIX2=0 D

 . S I=I+1,^TMP("PXTXT",$J,I)="                 *** ERROR ALERT ***"

 . S I=I+1,^TMP("PXTXT",$J,I)="Could NOT fix topic VA-Advanced Directives, data did NOT"

 . S I=I+1,^TMP("PXTXT",$J,I)="match national data base"

 I FIX2>0 D

 . S I=I+1,^TMP("PXTXT",$J,I)="                 ***  CHANGED  ***"

 . S I=I+1,^TMP("PXTXT",$J,I)="Modified topic VA-Advanced Directives for verbiage correction"

 . S I=I+1,^TMP("PXTXT",$J,I)="where used"

 D ^XMD ;send results

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPX157PST   4213     printed  Mar 13, 2025@21:30:19                                                                                                                                                                                                    Page 2

PX157PST  ;ALB/SCK - PX*1.0*157 POST INIT INSTALL

 +1       ;;1.0;PCE PATIENT CARE ENCOUNTER;**157**;Aug 12, 1996

 +2       ;

EN        ; Edit Education Topics VA-ADVANCE DIRECTIVES & VA-ADVANCED DIRECTIVES SCREENING

 +1       ; -- modifying to "advance directives" terminology.

EN1       ;check VA-ADVANCED DIRECTIVES SCREENING

 +1        SET FIX1=0

           SET FIX2=0

           SET IEN1=0

           SET U="^"

           SET WD1="VA-ADVANCED DIRECTIVES SCREENING"

           SET WD2="Advanced Directive Screening"

 +2        SET WD1N="VA-ADVANCE DIRECTIVES SCREENING"

           SET WD2N="Advance Directives Screening"

 +3        SET WD(1)="determine if the patient should receive Advanced Directive education. "

 +4        SET WDN(1)="determine if the patient should receive Advance Directives education."

 +5        SET WD(2)="Advanced Directive education.    "

 +6        SET WDN(2)="Advance Directives education."

 +7        SET IEN1=$ORDER(^AUTTEDT("B",WD1,IEN1))

           IF IEN1=""

               GOTO EN2

 +8        SET REDT=^AUTTEDT(IEN1,0)

 +9        IF $PIECE(REDT,U)'=WD1!($PIECE(REDT,U,4)'=WD2)

               GOTO EN2

 +10      ;I ^AUTTEDT(IEN1,11,2,0)'=WD(1) G EN2

 +11      ;I ^AUTTEDT(IEN1,12,4,0)'=WD(2) G EN2

SET1      ;SET CORRECT WORDING

 +1        SET FIX1=1

 +2        SET DA=IEN1

           SET DR=".01////^S X=WD1N"

           SET DIE="^AUTTEDT("

           DO ^DIE

 +3        SET DA=IEN1

           SET DR=".04////^S X=WD2N"

           SET DIE="^AUTTEDT("

           DO ^DIE

 +4        SET ^AUTTEDT(IEN1,11,2,0)=WDN(1)

           SET ^AUTTEDT(IEN1,12,4,0)=WDN(2)

EN2       ;check VA-ADVANCED DIRECTIVES

 +1        SET IEN2=0

           SET WD1A="VA-ADVANCED DIRECTIVES"

           SET WD2A="Advanced Directives"

 +2        SET WD1AN="VA-ADVANCE DIRECTIVES"

           SET WD2AN="Advance Directives"

 +3        SET WDA(1)="The patient and family will identify the implications of advanced"

 +4        SET WDA(2)="1.  Explain what an advanced directive is."

 +5        SET WDA(3)="2.  Explain the difference between advanced directives and a living will."

 +6        SET WDA(4)="5.  Identify a social worker to contact for furthur information as appropriate."

 +7        SET WDAN(1)="The patient and family will identify the implications of advance"

 +8        SET WDAN(2)="1.  Explain what an advance directives is."

 +9        SET WDAN(3)="2.  Explain the difference between advance directives and a living will."

 +10       SET WDAN(4)="5.  Identify a social worker to contact for further information as appropriate."

 +11       SET IEN2=$ORDER(^AUTTEDT("B",WD1A,IEN2))

           IF IEN2=""

               GOTO EN3

 +12       SET REDT=^AUTTEDT(IEN2,0)

 +13       IF $PIECE(REDT,U)'=WD1A!($PIECE(REDT,U,4)'=WD2A)

               GOTO EN3

 +14       IF ^AUTTEDT(IEN2,11,1,0)'=WDA(1)

               GOTO EN3

 +15       IF ^AUTTEDT(IEN2,12,1,0)'=WDA(2)

               GOTO EN3

 +16       IF ^AUTTEDT(IEN2,12,3,0)'=WDA(3)

               GOTO EN3

 +17       IF ^AUTTEDT(IEN2,12,10,0)'=WDA(4)

               GOTO EN3

SET2      ;SET CORRECT WORDING

 +1        SET FIX2=1

 +2        SET DA=IEN2

           SET DR=".01////^S X=WD1AN"

           SET DIE="^AUTTEDT("

           DO ^DIE

 +3        SET DA=IEN2

           SET DR=".04////^S X=WD2AN"

           SET DIE="^AUTTEDT("

           DO ^DIE

 +4        SET ^AUTTEDT(IEN2,11,1,0)=WDAN(1)

 +5        SET ^AUTTEDT(IEN2,12,1,0)=WDAN(2)

           SET ^AUTTEDT(IEN2,12,3,0)=WDAN(3)

 +6        SET ^AUTTEDT(IEN2,12,10,0)=WDAN(4)

EN3       ;MAIL MSG

END       ;EXIT PATH

 +1        DO MAIL

 +2        KILL DA,DR,DIE,IEN,IEN1,IEN2,WD,WDN,WDA,WDAN,WD1,WD1N,WD2,WD2N,WD1A,WD1AN,WD2A,WD2AN,FIX1,FIX2,REDT

 +3        QUIT

MAIL      ;Send results of Educ Topic fix in a mail message to initiator

 +1        NEW I,XMSUB,XMTEXT,XMDUZ,XMY,DIFROM

 +2        SET XMSUB="Patch PX*1.0*157 Educ topic modification completed"

 +3        SET XMDUZ="Patch PX*1.0*157 Educ topic modify job"

 +4        SET XMY(.5)=""

           if $GET(DUZ)

               SET XMY(DUZ)=""

 +5        SET XMTEXT="^TMP(""PXTXT"",$J,"

 +6        KILL ^TMP("PXTXT",$JOB)

 +7       ; set up header and count

 +8        SET I=3

 +9        SET ^TMP("PXTXT",$JOB,1)="The modification of Education Topics: VA-Advanced Directives and"

 +10       SET ^TMP("PXTXT",$JOB,2)="VA-Advanced Directives Screening, has completed"

 +11       SET ^TMP("PXTXT",$JOB,I)=""

           SET I=I+1

 +12       SET ^TMP("PXTXT",$JOB,I)=""

 +13       IF FIX1=0

               Begin DoDot:1

 +14               SET I=I+1

                   SET ^TMP("PXTXT",$JOB,I)="                 *** ERROR ALERT ***"

 +15               SET I=I+1

                   SET ^TMP("PXTXT",$JOB,I)="Could NOT fix topic VA-Advanced Directives Screening, data did NOT "

 +16               SET I=I+1

                   SET ^TMP("PXTXT",$JOB,I)="match national data base"

               End DoDot:1

 +17       IF FIX1>0

               Begin DoDot:1

 +18               SET I=I+1

                   SET ^TMP("PXTXT",$JOB,I)="                 ***  CHANGED  ***"

 +19               SET I=I+1

                   SET ^TMP("PXTXT",$JOB,I)="Modified topic VA-Advanced Directives Screening for verbiage"

 +20               SET I=I+1

                   SET ^TMP("PXTXT",$JOB,I)="correction where used"

               End DoDot:1

 +21       SET I=I+1

           SET ^TMP("PXTXT",$JOB,I)=""

 +22       IF FIX2=0

               Begin DoDot:1

 +23               SET I=I+1

                   SET ^TMP("PXTXT",$JOB,I)="                 *** ERROR ALERT ***"

 +24               SET I=I+1

                   SET ^TMP("PXTXT",$JOB,I)="Could NOT fix topic VA-Advanced Directives, data did NOT"

 +25               SET I=I+1

                   SET ^TMP("PXTXT",$JOB,I)="match national data base"

               End DoDot:1

 +26       IF FIX2>0

               Begin DoDot:1

 +27               SET I=I+1

                   SET ^TMP("PXTXT",$JOB,I)="                 ***  CHANGED  ***"

 +28               SET I=I+1

                   SET ^TMP("PXTXT",$JOB,I)="Modified topic VA-Advanced Directives for verbiage correction"

 +29               SET I=I+1

                   SET ^TMP("PXTXT",$JOB,I)="where used"

               End DoDot:1

 +30      ;send results

           DO ^XMD

 +31       QUIT

PX157PST.m