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
Q
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPX157PST 4213 printed Nov 22, 2024@17:35:37 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
