SD53P568 ;ALB/DAN Patch 568 install related activities ;12/8/10 11:28
;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
;
;DBIA Section
;1147 - $$ADD^XPDMENU
;2649 - $$ROUSIZE^DILF
;10141 - XPDUTL
;10086 - %ZIS
;10089 - %ZISC
;10006 - DIC
;10070 - XMD
;10103 - XLFDT
;10104 - XLFSTR
Q
;
PRETRAN ;Load conversion table into KIDS build
M @XPDGREF@("SDSTOP")=^XTMP("SDSTOP")
Q
;
POST ;Post installation processes
N SKIP,DUP,UPDATE
D UPDATEDD("O") ;allow editing of fields during post-install, restrict fields upon completion
D UPDMENU ;Add edit stop code option to menu
D LOADGSC ;Load gold stop codes
I +$G(XPDQUIT) Q ;Stop if error loading table
D CHKDUPS ;Identify any duplicate entries
D UPDCODES ;Update 40.7 to "gold" standard
D MAIL ;Send message showing duplicates and updates
D QCONFORM ;Run non-conforming clinic report in background
D UPDATEDD("C") ;Set restrictions on file to make entries uneditable.
D COMPILE ;Compile SDB input template
Q
;
LOADGSC ;Load gold stop code global for comparison and removal of duplicates
K ^XTMP("SDSTOP")
M ^XTMP("SDSTOP")=@XPDGREF@("SDSTOP")
I '$D(^XTMP("SDSTOP")) D BMES^XPDUTL("Conversion table not loaded - INSTALLATION ABORTED") S XPDQUIT=2 Q
S ^XTMP("SDSTOP",0)=$$FMADD^XLFDT(DT,30)_"^"_DT_"^Patch SD*5.3*568 conversion table" ;Set auto-delete date from XTMP global
Q
;
UPDATEDD(TYPE) ;Update DD for 40.7 to either unrestrict edits or restrict edits
N I
I TYPE="C" D ;restrict file
.S ^DD(40.7,.01,7.5)="I $G(DIC(0))[""L"",'$D(SDAUMF) D EN^DDIOL(""Entries can only be added by the Stop Code Counsel."","""",""!?5"") K X"
.F I=1:1:6 I $P(^DD(40.7,I,0),U,2)'["I" S $P(^DD(40.7,I,0),U,2)=$P(^DD(40.7,I,0),U,2)_"I" ;Makes all fields uneditable
I TYPE="O" D ;remove restrictions
.K ^DD(40.7,.01,7.5)
.F I=1:1:6 S $P(^DD(40.7,I,0),U,2)=$TR($P(^DD(40.7,I,0),U,2),"I","")
Q
;
N ADDED
S ADDED=$$ADD^XPDMENU("SDSUP","SD EDIT LOCAL STOP CODE NAME")
D BMES^XPDUTL("SD EDIT LOCAL STOP CODE NAME option "_$S('+$G(ADDED):"NOT ",1:"")_"added to menu SDSUP")
S ADDED=$$ADD^XPDMENU("ECX SETUP CLINIC","SD CLINIC EDIT LOG","8")
D BMES^XPDUTL("SD CLINIC EDIT LOG option "_$S('+$G(ADDED):"NOT ",1:"")_"added to menu ECX SETUP CLINIC")
Q
;
CHKDUPS ;Look through file 40.7 and check for entries with duplicate AMIS STOP CODES
N SC,IEN,GST,I,ARRAY,CNT,SIEN,NUMACT
S SC=0 F S SC=$O(^DIC(40.7,"C",SC)) Q:'+SC D
.K ARRAY S NUMACT=0
.S CNT=0,SIEN=0 F S SIEN=$O(^DIC(40.7,"C",SC,SIEN)) Q:'+SIEN S CNT=CNT+1,ARRAY(CNT,SIEN)=$S($P(^DIC(40.7,SIEN,0),U,3)'="":0,1:1) I ARRAY(CNT,SIEN)=1 S NUMACT=NUMACT+1
.I CNT'<2 D
..I '$D(^XTMP("SDSTOP",SC)) Q ;Stop code doesn't exist
..S GST=$S($P(^XTMP("SDSTOP",SC),U,4)'="":0,1:1) ;gold entry status 0 - inactive, 1 - active
..Q:'GST ;Stop if gold entry is inactive, no duplicates can exist
..F I=1:1:CNT S IEN=$O(ARRAY(I,0)) D
...I NUMACT=0 S DUP(SC,IEN)="",SKIP(IEN)="" Q
...I NUMACT=1 I 'ARRAY(I,IEN) S SKIP(IEN)="" Q
...I NUMACT'<2 D
....I ARRAY(I,IEN) S DUP(SC,IEN)="",SKIP(IEN)=""
....I 'ARRAY(I,IEN) S SKIP(IEN)=""
Q
;
UPDCODES ;Compare existing entries in 40.7 with "gold" entries
N SC,IEN,DIE,DA,DR,LINE,GOLD,DIC,NODE,X,Y,SDAUMF
S SC=0 F S SC=$O(^DIC(40.7,"C",SC)) Q:'+SC D
.S IEN=0 F S IEN=$O(^DIC(40.7,"C",SC,IEN)) Q:'+IEN D
..K LINE,GOLD,DR,DA
..I '$D(^XTMP("SDSTOP",SC)) D Q ;Entry in 40.7 isn't in gold listing
...I $P(^DIC(40.7,IEN,0),U,3)="" S DIE=40.7,DA=IEN,DR="2////3101101" D ^DIE S UPDATE("I",IEN)="" ;Make entry inactive as of 11/1/10 if not already inactive
..I $D(SKIP(IEN)) Q ;If entry is in the "SKIP" array then it doesn't need to be touched
..;Compare entries, update where needed
..S LINE=^DIC(40.7,IEN,0)
..S GOLD=^XTMP("SDSTOP",SC)
..I '(SC'<451&(SC'>485)&(SC'=457)&(SC'=474)&(SC'=480)&(SC'=481)) I $P(LINE,U)'=$P(GOLD,U) S DR=".01////"_$P(GOLD,U)_";" S UPDATE("U",IEN)=$P(LINE,U)_"~"_$P(GOLD,U) ;If not a local entry, then compare name field
..I $P(LINE,U,6)'=$E($P(GOLD,U,2)) S DR=$G(DR)_"5////"_$E($P(GOLD,U,2))_";" S $P(UPDATE("U",IEN),U,2)=$P(LINE,U,6)_"~"_$E($P(GOLD,U,2)) ;if restriction type doesn't match, update it
..I $P(LINE,U,7)'=$P(GOLD,U,3) S DR=$G(DR)_"6////"_$S($P(GOLD,U,3)="":"@",1:$P(GOLD,U,3))_";" S $P(UPDATE("U",IEN),U,3)=$P(LINE,U,7)_"~"_$P(GOLD,U,3) ;If restriction date doesn't match, update it
..I $P(LINE,U,3)'=$P(GOLD,U,4) S DR=$G(DR)_"2////"_$S($P(GOLD,U,4)="":"@",1:$P(GOLD,U,4)) S $P(UPDATE("U",IEN),U,4)=$P(LINE,U,3)_"~"_$P(GOLD,U,4) ;if inactivation date doesn't match, update it
..I $D(DR) S DA=IEN,DIE=40.7 D ^DIE ;update entry to "gold" values
;Add entries from GOLD that aren't in 40.7
S SC=0 F S SC=$O(^XTMP("SDSTOP",SC)) Q:'+SC D
.I '$D(^DIC(40.7,"C",SC)) D
..S SDAUMF=1
..S NODE=^XTMP("SDSTOP",SC)
..S DIC=40.7,DIC(0)="LX",X=$P(NODE,U),DIC("DR")="1////"_SC_";2////"_$P(NODE,U,4)_";5////"_$E($P(NODE,U,2))_";6////"_$P(NODE,U,3)
..D ^DIC ;adds new entries with fields identified above
..I Y=-1!('+$P(Y,U,3)) S UPDATE("NA",SC)="" Q ;if entry fails, store it so it can be reported
..S UPDATE("N",SC)=""
Q
;
MAIL ;Send message indicating post install is finished
N XMSUB,XMTEXT,XMDUZ,XMY,XMZ,SDTXT,CNT,DIFROM,DIEN,NODE,SC,NAME,IEN,I,PIECE
S XMDUZ="PATCH SD*5.3*568 POST-INSTALL"
D GETXMY("ECXMGR",.XMY),GETXMY("SD SUPERVISOR",.XMY) S XMY("G.CSPIMS@FORUM.VA.GOV")=""
I '$D(DUP) D ;No duplicates
.S SDTXT(1)="The Duplicate Stop Code Clean Up Process has been completed.",SDTXT(2)="No active duplicate stop codes were found."
I $D(DUP) D ;Duplicates found
.S SDTXT(1)="IEN"_$$REPEAT^XLFSTR(" ",7)_"NAME"_$$REPEAT^XLFSTR(" ",36)_"AMIS STOP CODE"
.S SDTXT(2)=" ",CNT=2
.S SC=0 F S SC=$O(DUP(SC)) Q:'+SC S DIEN=0 F S DIEN=$O(DUP(SC,DIEN)) Q:'+DIEN D
..S NAME=$P($G(^DIC(40.7,DIEN,0)),U,1)
..S CNT=CNT+1,SDTXT(CNT)=DIEN_$$REPEAT^XLFSTR(" ",(10-$L(DIEN)))_NAME_$$REPEAT^XLFSTR(" ",(40-$L(NAME)))_SC
.S CNT=CNT+1,SDTXT(CNT)=" "
.S CNT=CNT+1,SDTXT(CNT)="**PLEASE log a REMEDY TICKET to the Scheduling package for",CNT=CNT+1,SDTXT(CNT)="assistance from the PIMS Team in correction of these duplicates.**"
S XMTEXT="SDTXT(",XMSUB="DUPLICATE STOP CODE CLEAN UP"
D ^XMD ;Send duplicate clean up message
;Now set up and send clean up/standardization message
K SDTXT
I '$D(UPDATE) S SDTXT(1)="The stop code clean up/standardization process has been completed",SDTXT(2)="and no stop codes were inactivated, modified, or added."
I $D(UPDATE) D
.S CNT=1
.I $D(UPDATE("I")) D ;codes that were not found in the gold listing
..S SDTXT(CNT)="The following entries were not found in the standardized list",CNT=CNT+1,SDTXT(CNT)="and were inactivated with a date of 11/1/10.",CNT=CNT+1,SDTXT(CNT)="",CNT=CNT+1
..S SDTXT(CNT)="CODE NAME",CNT=CNT+1
..S IEN=0 F S IEN=$O(UPDATE("I",IEN)) Q:'+IEN D
...S NODE=^DIC(40.7,IEN,0)
...S SDTXT(CNT)=$P(NODE,U,2)_$$REPEAT^XLFSTR(" ",(6-$L($P(NODE,U,2))))_$P(NODE,U),CNT=CNT+1
..S SDTXT(CNT)="",CNT=CNT+1
.I $D(UPDATE("U")) D ;codes that were modified to match the standardized listing
..S SDTXT(CNT)="The following entries have been modified to match the standardized list.",CNT=CNT+1,SDTXT(CNT)="",CNT=CNT+1
..S SDTXT(CNT)=" CODE NAME"_$$REPEAT^XLFSTR(" ",28)_"RESTRCT RESTRCT INACT",CNT=CNT+1,SDTXT(CNT)=$$REPEAT^XLFSTR(" ",42)_"TYPE DATE DATE",CNT=CNT+1,SDTXT(CNT)="",CNT=CNT+1
..S IEN=0 F S IEN=$O(UPDATE("U",IEN)) Q:'+IEN D
...S NODE=^DIC(40.7,IEN,0)
...S SDTXT(CNT)="Old: "_$P(NODE,U,2)_$$REPEAT^XLFSTR(" ",(5-$L($P(NODE,U,2))))
...F I=1:1:4 S PIECE=$P($P(UPDATE("U",IEN),U,I),"~") D
....S SDTXT(CNT)=SDTXT(CNT)_$S(I=1!(I=2):PIECE,1:$$FMTE^XLFDT(PIECE,2))_$$REPEAT^XLFSTR(" ",($S(I=1:32,1:10)-$L(PIECE)))
...S CNT=CNT+1,SDTXT(CNT)="New: "_$P(NODE,U,2)_$$REPEAT^XLFSTR(" ",(5-$L($P(NODE,U,2))))
...F I=1:1:4 S PIECE=$P($P(UPDATE("U",IEN),U,I),"~",2) D
....S SDTXT(CNT)=SDTXT(CNT)_$S(I=1!(I=2):PIECE,1:$$FMTE^XLFDT(PIECE,2))_$$REPEAT^XLFSTR(" ",($S(I=1:32,1:10)-$L(PIECE)))
...S CNT=CNT+1,SDTXT(CNT)="",CNT=CNT+1
.I $D(UPDATE("N")) D ;new entries that were added to 40.7
..S SDTXT(CNT)="The following entries were added to your CLINIC STOP (#40.7) file.",CNT=CNT+1
..S SDTXT(CNT)="",CNT=CNT+1,SDTXT(CNT)="CODE NAME",CNT=CNT+1
..S IEN=0 F S IEN=$O(UPDATE("N",IEN)) Q:'+IEN S SDTXT(CNT)=IEN_$$REPEAT^XLFSTR(" ",(6-$L(IEN)))_$P(^XTMP("SDSTOP",IEN),U),CNT=CNT+1
..S SDTXT(CNT)="",CNT=CNT+1
.I $D(UPDATE("NA")) D ;new entries that couldn't be added for some reason
..S SDTXT(CNT)="The following entries were NOT added to your CLINIC STOP (#40.7) file.",CNT=CNT+1,SDTXT(CNT)="Please log a remedy ticket for assistance in adding these entries.",CNT=CNT+1
..S SDTXT(CNT)="",CNT=CNT+1,SDTXT(CNT)="CODE NAME",CNT=CNT+1
..S IEN=0 F S IEN=$O(UPDATE("NA",IEN)) Q:'+IEN S SDTXT(CNT)=IEN_$$REPEAT^XLFSTR(" ",(6-$L(IEN)))_$P(^XTMP("SDSTOP",IEN),U),CNT=CNT+1
S XMTEXT="SDTXT(",XMSUB="Clinic Stop Code file (#40.7) standardization/clean up"
D GETXMY("ECXMGR",.XMY),GETXMY("SD SUPERVISOR",.XMY)
D ^XMD
Q
;
CONFORM ;Run the two non-conforming clinic reports
N DIC,X,Y,XMSUB,XMDUZ,XMY,IOP,SDPCF,XMQUIET,ECXPCF,ECX,REP,DIFROM
F REP=1:1:2 D
.S DIC=3.5,DIC(0)="X",X="P-MESSAGE-HFS" D ^DIC
.Q:'+Y ;Stop if p-message device doesn't exist
.S IOP="`"_+Y ;Set IOP to p-message device
.S XMDUZ="Patch SD*5.3*568 Post-install"
.S XMSUB="Non-Conforming Clinics Stop Code Report for "_$S(REP=1:"Scheduling",1:"DSS")
.S XMQUIET=1 ;no screen interaction with p-message
.D ^%ZIS Q:POP ;Stop if there is a problem with p-message device
.U IO
.I REP=1 D
..K XMY
..D GETXMY("SD SUPERVISOR",.XMY),GETXMY("ECXMGR",.XMY)
..S SDPCF="A"
..D PROCESS^SDSCRP
.I REP=2 D
..K XMY
..D GETXMY("ECXMGR",.XMY),GETXMY("SD SUPERVISOR",.XMY)
..S ECXPCF="A"
..;Synch primary & secondary stop codes from file #44 with #728.44
..S ECX=0 F S ECX=$O(^ECX(728.44,ECX)) Q:'ECX D FIX^ECXSCLD(ECX)
..D PROCESS^ECXSCRP
.D ^%ZISC
Q
;
GETXMY(KEY,XMY) ;
I $G(KEY)'="" M XMY=^XUSEC(KEY)
S:$G(DUZ) XMY(DUZ)="" ;Make sure there's at least one recipient
Q
;
QCONFORM ;Queue non-conforming reports
N ZTSK,ZTRTN,ZTDESC,ZTIO,ZTDTH
S ZTRTN="CONFORM^SD53P568",ZTDESC="NON-CONFORMING REPORTS FROM PATCH SD*5.3*568",ZTIO="",ZTDTH=$H
D ^%ZTLOAD
I '$D(ZTSK) D BMES^XPDUTL("NON-CONFORMING REPORTS NOT QUEUED! RUN CONFORM^SD53P568 AFTER INSTALL FINISHES") Q
D BMES^XPDUTL("NON-CONFORMING REPORTS QUEUED AS TASK # "_$G(ZTSK))
Q
;
COMPILE ;Compiles SDB input template to make sure changes to file 44 are included
N X,Y,DMAX
S X="SDBT"
S Y=$O(^DIE("B","SDB",0)) Q:'+Y ;Template not found
S DMAX=$$ROUSIZE^DILF
D EN^DIEZ
Q
SD53P568 ;ALB/DAN Patch 568 install related activities ;12/8/10 11:28
+1 ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
+2 ;
+3 ;DBIA Section
+4 ;1147 - $$ADD^XPDMENU
+5 ;2649 - $$ROUSIZE^DILF
+6 ;10141 - XPDUTL
+7 ;10086 - %ZIS
+8 ;10089 - %ZISC
+9 ;10006 - DIC
+10 ;10070 - XMD
+11 ;10103 - XLFDT
+12 ;10104 - XLFSTR
+13 QUIT
+14 ;
PRETRAN ;Load conversion table into KIDS build
+1 MERGE @XPDGREF@("SDSTOP")=^XTMP("SDSTOP")
+2 QUIT
+3 ;
POST ;Post installation processes
+1 NEW SKIP,DUP,UPDATE
+2 ;allow editing of fields during post-install, restrict fields upon completion
DO UPDATEDD("O")
+3 ;Add edit stop code option to menu
DO UPDMENU
+4 ;Load gold stop codes
DO LOADGSC
+5 ;Stop if error loading table
IF +$GET(XPDQUIT)
QUIT
+6 ;Identify any duplicate entries
DO CHKDUPS
+7 ;Update 40.7 to "gold" standard
DO UPDCODES
+8 ;Send message showing duplicates and updates
DO MAIL
+9 ;Run non-conforming clinic report in background
DO QCONFORM
+10 ;Set restrictions on file to make entries uneditable.
DO UPDATEDD("C")
+11 ;Compile SDB input template
DO COMPILE
+12 QUIT
+13 ;
LOADGSC ;Load gold stop code global for comparison and removal of duplicates
+1 KILL ^XTMP("SDSTOP")
+2 MERGE ^XTMP("SDSTOP")=@XPDGREF@("SDSTOP")
+3 IF '$DATA(^XTMP("SDSTOP"))
DO BMES^XPDUTL("Conversion table not loaded - INSTALLATION ABORTED")
SET XPDQUIT=2
QUIT
+4 ;Set auto-delete date from XTMP global
SET ^XTMP("SDSTOP",0)=$$FMADD^XLFDT(DT,30)_"^"_DT_"^Patch SD*5.3*568 conversion table"
+5 QUIT
+6 ;
UPDATEDD(TYPE) ;Update DD for 40.7 to either unrestrict edits or restrict edits
+1 NEW I
+2 ;restrict file
IF TYPE="C"
Begin DoDot:1
+3 SET ^DD(40.7,.01,7.5)="I $G(DIC(0))[""L"",'$D(SDAUMF) D EN^DDIOL(""Entries can only be added by the Stop Code Counsel."","""",""!?5"") K X"
+4 ;Makes all fields uneditable
FOR I=1:1:6
IF $PIECE(^DD(40.7,I,0),U,2)'["I"
SET $PIECE(^DD(40.7,I,0),U,2)=$PIECE(^DD(40.7,I,0),U,2)_"I"
End DoDot:1
+5 ;remove restrictions
IF TYPE="O"
Begin DoDot:1
+6 KILL ^DD(40.7,.01,7.5)
+7 FOR I=1:1:6
SET $PIECE(^DD(40.7,I,0),U,2)=$TRANSLATE($PIECE(^DD(40.7,I,0),U,2),"I","")
End DoDot:1
+8 QUIT
+9 ;
+1 NEW ADDED
+2 SET ADDED=$$ADD^XPDMENU("SDSUP","SD EDIT LOCAL STOP CODE NAME")
+3 DO BMES^XPDUTL("SD EDIT LOCAL STOP CODE NAME option "_$SELECT('+$GET(ADDED):"NOT ",1:"")_"added to menu SDSUP")
+4 SET ADDED=$$ADD^XPDMENU("ECX SETUP CLINIC","SD CLINIC EDIT LOG","8")
+5 DO BMES^XPDUTL("SD CLINIC EDIT LOG option "_$SELECT('+$GET(ADDED):"NOT ",1:"")_"added to menu ECX SETUP CLINIC")
+6 QUIT
+7 ;
CHKDUPS ;Look through file 40.7 and check for entries with duplicate AMIS STOP CODES
+1 NEW SC,IEN,GST,I,ARRAY,CNT,SIEN,NUMACT
+2 SET SC=0
FOR
SET SC=$ORDER(^DIC(40.7,"C",SC))
IF '+SC
QUIT
Begin DoDot:1
+3 KILL ARRAY
SET NUMACT=0
+4 SET CNT=0
SET SIEN=0
FOR
SET SIEN=$ORDER(^DIC(40.7,"C",SC,SIEN))
IF '+SIEN
QUIT
SET CNT=CNT+1
SET ARRAY(CNT,SIEN)=$SELECT($PIECE(^DIC(40.7,SIEN,0),U,3)'="":0,1:1)
IF ARRAY(CNT,SIEN)=1
SET NUMACT=NUMACT+1
+5 IF CNT'<2
Begin DoDot:2
+6 ;Stop code doesn't exist
IF '$DATA(^XTMP("SDSTOP",SC))
QUIT
+7 ;gold entry status 0 - inactive, 1 - active
SET GST=$SELECT($PIECE(^XTMP("SDSTOP",SC),U,4)'="":0,1:1)
+8 ;Stop if gold entry is inactive, no duplicates can exist
IF 'GST
QUIT
+9 FOR I=1:1:CNT
SET IEN=$ORDER(ARRAY(I,0))
Begin DoDot:3
+10 IF NUMACT=0
SET DUP(SC,IEN)=""
SET SKIP(IEN)=""
QUIT
+11 IF NUMACT=1
IF 'ARRAY(I,IEN)
SET SKIP(IEN)=""
QUIT
+12 IF NUMACT'<2
Begin DoDot:4
+13 IF ARRAY(I,IEN)
SET DUP(SC,IEN)=""
SET SKIP(IEN)=""
+14 IF 'ARRAY(I,IEN)
SET SKIP(IEN)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
UPDCODES ;Compare existing entries in 40.7 with "gold" entries
+1 NEW SC,IEN,DIE,DA,DR,LINE,GOLD,DIC,NODE,X,Y,SDAUMF
+2 SET SC=0
FOR
SET SC=$ORDER(^DIC(40.7,"C",SC))
IF '+SC
QUIT
Begin DoDot:1
+3 SET IEN=0
FOR
SET IEN=$ORDER(^DIC(40.7,"C",SC,IEN))
IF '+IEN
QUIT
Begin DoDot:2
+4 KILL LINE,GOLD,DR,DA
+5 ;Entry in 40.7 isn't in gold listing
IF '$DATA(^XTMP("SDSTOP",SC))
Begin DoDot:3
+6 ;Make entry inactive as of 11/1/10 if not already inactive
IF $PIECE(^DIC(40.7,IEN,0),U,3)=""
SET DIE=40.7
SET DA=IEN
SET DR="2////3101101"
DO ^DIE
SET UPDATE("I",IEN)=""
End DoDot:3
QUIT
+7 ;If entry is in the "SKIP" array then it doesn't need to be touched
IF $DATA(SKIP(IEN))
QUIT
+8 ;Compare entries, update where needed
+9 SET LINE=^DIC(40.7,IEN,0)
+10 SET GOLD=^XTMP("SDSTOP",SC)
+11 ;If not a local entry, then compare name field
IF '(SC'<451&(SC'>485)&(SC'=457)&(SC'=474)&(SC'=480)&(SC'=481))
IF $PIECE(LINE,U)'=$PIECE(GOLD,U)
SET DR=".01////"_$PIECE(GOLD,U)_";"
SET UPDATE("U",IEN)=$PIECE(LINE,U)_"~"_$PIECE(GOLD,U)
+12 ;if restriction type doesn't match, update it
IF $PIECE(LINE,U,6)'=$EXTRACT($PIECE(GOLD,U,2))
SET DR=$GET(DR)_"5////"_$EXTRACT($PIECE(GOLD,U,2))_";"
SET $PIECE(UPDATE("U",IEN),U,2)=$PIECE(LINE,U,6)_"~"_$EXTRACT($PIECE(GOLD,U,2))
+13 ;If restriction date doesn't match, update it
IF $PIECE(LINE,U,7)'=$PIECE(GOLD,U,3)
SET DR=$GET(DR)_"6////"_$SELECT($PIECE(GOLD,U,3)="":"@",1:$PIECE(GOLD,U,3))_";"
SET $PIECE(UPDATE("U",IEN),U,3)=$PIECE(LINE,U,7)_"~"_$PIECE(GOLD,U,3)
+14 ;if inactivation date doesn't match, update it
IF $PIECE(LINE,U,3)'=$PIECE(GOLD,U,4)
SET DR=$GET(DR)_"2////"_$SELECT($PIECE(GOLD,U,4)="":"@",1:$PIECE(GOLD,U,4))
SET $PIECE(UPDATE("U",IEN),U,4)=$PIECE(LINE,U,3)_"~"_$PIECE(GOLD,U,4)
+15 ;update entry to "gold" values
IF $DATA(DR)
SET DA=IEN
SET DIE=40.7
DO ^DIE
End DoDot:2
End DoDot:1
+16 ;Add entries from GOLD that aren't in 40.7
+17 SET SC=0
FOR
SET SC=$ORDER(^XTMP("SDSTOP",SC))
IF '+SC
QUIT
Begin DoDot:1
+18 IF '$DATA(^DIC(40.7,"C",SC))
Begin DoDot:2
+19 SET SDAUMF=1
+20 SET NODE=^XTMP("SDSTOP",SC)
+21 SET DIC=40.7
SET DIC(0)="LX"
SET X=$PIECE(NODE,U)
SET DIC("DR")="1////"_SC_";2////"_$PIECE(NODE,U,4)_";5////"_$EXTRACT($PIECE(NODE,U,2))_";6////"_$PIECE(NODE,U,3)
+22 ;adds new entries with fields identified above
DO ^DIC
+23 ;if entry fails, store it so it can be reported
IF Y=-1!('+$PIECE(Y,U,3))
SET UPDATE("NA",SC)=""
QUIT
+24 SET UPDATE("N",SC)=""
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
MAIL ;Send message indicating post install is finished
+1 NEW XMSUB,XMTEXT,XMDUZ,XMY,XMZ,SDTXT,CNT,DIFROM,DIEN,NODE,SC,NAME,IEN,I,PIECE
+2 SET XMDUZ="PATCH SD*5.3*568 POST-INSTALL"
+3 DO GETXMY("ECXMGR",.XMY)
DO GETXMY("SD SUPERVISOR",.XMY)
SET XMY("G.CSPIMS@FORUM.VA.GOV")=""
+4 ;No duplicates
IF '$DATA(DUP)
Begin DoDot:1
+5 SET SDTXT(1)="The Duplicate Stop Code Clean Up Process has been completed."
SET SDTXT(2)="No active duplicate stop codes were found."
End DoDot:1
+6 ;Duplicates found
IF $DATA(DUP)
Begin DoDot:1
+7 SET SDTXT(1)="IEN"_$$REPEAT^XLFSTR(" ",7)_"NAME"_$$REPEAT^XLFSTR(" ",36)_"AMIS STOP CODE"
+8 SET SDTXT(2)=" "
SET CNT=2
+9 SET SC=0
FOR
SET SC=$ORDER(DUP(SC))
IF '+SC
QUIT
SET DIEN=0
FOR
SET DIEN=$ORDER(DUP(SC,DIEN))
IF '+DIEN
QUIT
Begin DoDot:2
+10 SET NAME=$PIECE($GET(^DIC(40.7,DIEN,0)),U,1)
+11 SET CNT=CNT+1
SET SDTXT(CNT)=DIEN_$$REPEAT^XLFSTR(" ",(10-$LENGTH(DIEN)))_NAME_$$REPEAT^XLFSTR(" ",(40-$LENGTH(NAME)))_SC
End DoDot:2
+12 SET CNT=CNT+1
SET SDTXT(CNT)=" "
+13 SET CNT=CNT+1
SET SDTXT(CNT)="**PLEASE log a REMEDY TICKET to the Scheduling package for"
SET CNT=CNT+1
SET SDTXT(CNT)="assistance from the PIMS Team in correction of these duplicates.**"
End DoDot:1
+14 SET XMTEXT="SDTXT("
SET XMSUB="DUPLICATE STOP CODE CLEAN UP"
+15 ;Send duplicate clean up message
DO ^XMD
+16 ;Now set up and send clean up/standardization message
+17 KILL SDTXT
+18 IF '$DATA(UPDATE)
SET SDTXT(1)="The stop code clean up/standardization process has been completed"
SET SDTXT(2)="and no stop codes were inactivated, modified, or added."
+19 IF $DATA(UPDATE)
Begin DoDot:1
+20 SET CNT=1
+21 ;codes that were not found in the gold listing
IF $DATA(UPDATE("I"))
Begin DoDot:2
+22 SET SDTXT(CNT)="The following entries were not found in the standardized list"
SET CNT=CNT+1
SET SDTXT(CNT)="and were inactivated with a date of 11/1/10."
SET CNT=CNT+1
SET SDTXT(CNT)=""
SET CNT=CNT+1
+23 SET SDTXT(CNT)="CODE NAME"
SET CNT=CNT+1
+24 SET IEN=0
FOR
SET IEN=$ORDER(UPDATE("I",IEN))
IF '+IEN
QUIT
Begin DoDot:3
+25 SET NODE=^DIC(40.7,IEN,0)
+26 SET SDTXT(CNT)=$PIECE(NODE,U,2)_$$REPEAT^XLFSTR(" ",(6-$LENGTH($PIECE(NODE,U,2))))_$PIECE(NODE,U)
SET CNT=CNT+1
End DoDot:3
+27 SET SDTXT(CNT)=""
SET CNT=CNT+1
End DoDot:2
+28 ;codes that were modified to match the standardized listing
IF $DATA(UPDATE("U"))
Begin DoDot:2
+29 SET SDTXT(CNT)="The following entries have been modified to match the standardized list."
SET CNT=CNT+1
SET SDTXT(CNT)=""
SET CNT=CNT+1
+30 SET SDTXT(CNT)=" CODE NAME"_$$REPEAT^XLFSTR(" ",28)_"RESTRCT RESTRCT INACT"
SET CNT=CNT+1
SET SDTXT(CNT)=$$REPEAT^XLFSTR(" ",42)_"TYPE DATE DATE"
SET CNT=CNT+1
SET SDTXT(CNT)=""
SET CNT=CNT+1
+31 SET IEN=0
FOR
SET IEN=$ORDER(UPDATE("U",IEN))
IF '+IEN
QUIT
Begin DoDot:3
+32 SET NODE=^DIC(40.7,IEN,0)
+33 SET SDTXT(CNT)="Old: "_$PIECE(NODE,U,2)_$$REPEAT^XLFSTR(" ",(5-$LENGTH($PIECE(NODE,U,2))))
+34 FOR I=1:1:4
SET PIECE=$PIECE($PIECE(UPDATE("U",IEN),U,I),"~")
Begin DoDot:4
+35 SET SDTXT(CNT)=SDTXT(CNT)_$SELECT(I=1!(I=2):PIECE,1:$$FMTE^XLFDT(PIECE,2))_$$REPEAT^XLFSTR(" ",($SELECT(I=1:32,1:10)-$LENGTH(PIECE)))
End DoDot:4
+36 SET CNT=CNT+1
SET SDTXT(CNT)="New: "_$PIECE(NODE,U,2)_$$REPEAT^XLFSTR(" ",(5-$LENGTH($PIECE(NODE,U,2))))
+37 FOR I=1:1:4
SET PIECE=$PIECE($PIECE(UPDATE("U",IEN),U,I),"~",2)
Begin DoDot:4
+38 SET SDTXT(CNT)=SDTXT(CNT)_$SELECT(I=1!(I=2):PIECE,1:$$FMTE^XLFDT(PIECE,2))_$$REPEAT^XLFSTR(" ",($SELECT(I=1:32,1:10)-$LENGTH(PIECE)))
End DoDot:4
+39 SET CNT=CNT+1
SET SDTXT(CNT)=""
SET CNT=CNT+1
End DoDot:3
End DoDot:2
+40 ;new entries that were added to 40.7
IF $DATA(UPDATE("N"))
Begin DoDot:2
+41 SET SDTXT(CNT)="The following entries were added to your CLINIC STOP (#40.7) file."
SET CNT=CNT+1
+42 SET SDTXT(CNT)=""
SET CNT=CNT+1
SET SDTXT(CNT)="CODE NAME"
SET CNT=CNT+1
+43 SET IEN=0
FOR
SET IEN=$ORDER(UPDATE("N",IEN))
IF '+IEN
QUIT
SET SDTXT(CNT)=IEN_$$REPEAT^XLFSTR(" ",(6-$LENGTH(IEN)))_$PIECE(^XTMP("SDSTOP",IEN),U)
SET CNT=CNT+1
+44 SET SDTXT(CNT)=""
SET CNT=CNT+1
End DoDot:2
+45 ;new entries that couldn't be added for some reason
IF $DATA(UPDATE("NA"))
Begin DoDot:2
+46 SET SDTXT(CNT)="The following entries were NOT added to your CLINIC STOP (#40.7) file."
SET CNT=CNT+1
SET SDTXT(CNT)="Please log a remedy ticket for assistance in adding these entries."
SET CNT=CNT+1
+47 SET SDTXT(CNT)=""
SET CNT=CNT+1
SET SDTXT(CNT)="CODE NAME"
SET CNT=CNT+1
+48 SET IEN=0
FOR
SET IEN=$ORDER(UPDATE("NA",IEN))
IF '+IEN
QUIT
SET SDTXT(CNT)=IEN_$$REPEAT^XLFSTR(" ",(6-$LENGTH(IEN)))_$PIECE(^XTMP("SDSTOP",IEN),U)
SET CNT=CNT+1
End DoDot:2
End DoDot:1
+49 SET XMTEXT="SDTXT("
SET XMSUB="Clinic Stop Code file (#40.7) standardization/clean up"
+50 DO GETXMY("ECXMGR",.XMY)
DO GETXMY("SD SUPERVISOR",.XMY)
+51 DO ^XMD
+52 QUIT
+53 ;
CONFORM ;Run the two non-conforming clinic reports
+1 NEW DIC,X,Y,XMSUB,XMDUZ,XMY,IOP,SDPCF,XMQUIET,ECXPCF,ECX,REP,DIFROM
+2 FOR REP=1:1:2
Begin DoDot:1
+3 SET DIC=3.5
SET DIC(0)="X"
SET X="P-MESSAGE-HFS"
DO ^DIC
+4 ;Stop if p-message device doesn't exist
IF '+Y
QUIT
+5 ;Set IOP to p-message device
SET IOP="`"_+Y
+6 SET XMDUZ="Patch SD*5.3*568 Post-install"
+7 SET XMSUB="Non-Conforming Clinics Stop Code Report for "_$SELECT(REP=1:"Scheduling",1:"DSS")
+8 ;no screen interaction with p-message
SET XMQUIET=1
+9 ;Stop if there is a problem with p-message device
DO ^%ZIS
IF POP
QUIT
+10 USE IO
+11 IF REP=1
Begin DoDot:2
+12 KILL XMY
+13 DO GETXMY("SD SUPERVISOR",.XMY)
DO GETXMY("ECXMGR",.XMY)
+14 SET SDPCF="A"
+15 DO PROCESS^SDSCRP
End DoDot:2
+16 IF REP=2
Begin DoDot:2
+17 KILL XMY
+18 DO GETXMY("ECXMGR",.XMY)
DO GETXMY("SD SUPERVISOR",.XMY)
+19 SET ECXPCF="A"
+20 ;Synch primary & secondary stop codes from file #44 with #728.44
+21 SET ECX=0
FOR
SET ECX=$ORDER(^ECX(728.44,ECX))
IF 'ECX
QUIT
DO FIX^ECXSCLD(ECX)
+22 DO PROCESS^ECXSCRP
End DoDot:2
+23 DO ^%ZISC
End DoDot:1
+24 QUIT
+25 ;
GETXMY(KEY,XMY) ;
+1 IF $GET(KEY)'=""
MERGE XMY=^XUSEC(KEY)
+2 ;Make sure there's at least one recipient
IF $GET(DUZ)
SET XMY(DUZ)=""
+3 QUIT
+4 ;
QCONFORM ;Queue non-conforming reports
+1 NEW ZTSK,ZTRTN,ZTDESC,ZTIO,ZTDTH
+2 SET ZTRTN="CONFORM^SD53P568"
SET ZTDESC="NON-CONFORMING REPORTS FROM PATCH SD*5.3*568"
SET ZTIO=""
SET ZTDTH=$HOROLOG
+3 DO ^%ZTLOAD
+4 IF '$DATA(ZTSK)
DO BMES^XPDUTL("NON-CONFORMING REPORTS NOT QUEUED! RUN CONFORM^SD53P568 AFTER INSTALL FINISHES")
QUIT
+5 DO BMES^XPDUTL("NON-CONFORMING REPORTS QUEUED AS TASK # "_$GET(ZTSK))
+6 QUIT
+7 ;
COMPILE ;Compiles SDB input template to make sure changes to file 44 are included
+1 NEW X,Y,DMAX
+2 SET X="SDBT"
+3 ;Template not found
SET Y=$ORDER(^DIE("B","SDB",0))
IF '+Y
QUIT
+4 SET DMAX=$$ROUSIZE^DILF
+5 DO EN^DIEZ
+6 QUIT
