SCMCLN ;swo/oifobp temp clean up routine
;;5.3;Scheduling;**498**;8.13.1993;Build 23
;lets clean-up danglers in 404.43 PATIENT TEAM POSITION ASSIGNMENT
;1st run thru 404.43 and find the pointers to 404.42 PATIENT TEAM ASSIGNMENT
;pointer is piece one of 404.43
N CNT1,CNT2,DA,DIK,DIR,V1,V2,V3,V4,ZNODE
S (CNT1,CNT2)=0
W !,"Checking for ""Ghost Entries"" in the PATIENT TEAM POSITION ASSIGNMENT FILE."
W !,"This may take a moment. You will be provided with a list showing corrupted"
W !,"file entries. To perform a clean-up accept the ""Yes"" prompt after the list"
W !,"is displayed. Answer ""No"" to abort the clean-up.",!
S V1=0 F S V1=$O(^SCPT(404.43,V1)) Q:'V1 D
. S CNT1=CNT1+1
. S ZNODE=$G(^SCPT(404.43,V1,0))
. S V2=$P(ZNODE,U) Q:V2=""
. S V3=$G(^SCPT(404.42,V2,0)) I V3="" D LOG
D SHOW Q:POP
I $G(CNT2)<1 W !,"Nothing to clean up...." Q
S DIR("?")="Answerng Yes will perform a clean-up of the ghost entries"
S DIR("A")="Perform File Clean-Up"
S DIR(0)="Y",DIR("B")="No" D ^DIR
I Y D DEL
D CLEAN
Q
LOG ;build a list in ^TMP("SCMCLN",$J
S ^TMP("SCMCLN",$J,V1)=""
S CNT2=CNT2+1
Q
SHOW ;see what we got
S DIOEND="D FOOT^SCMCLN"
S DIC="^SCPT(404.43,",L=0,BY="@.03",(FR,TO)="",FLDS="[CAPTIONED]"
S BY(0)="^TMP(""SCMCLN"",$J,"
S L(0)=1 D EN1^DIP
Q
DEL ;delete the danglers
;check #404.48 -- PCMM HL7 EVENT FILE .07 field EVENT POINTER points to 404.43
;variable pointer, yeck!
S DIK="^SCPT(404.43,"
S V1=0 F S V1=$O(^TMP("SCMCLN",$J,V1)) Q:'V1 D
.S V4=""""_V1_";SCPT(404.43,"_""""
.I $O(^SCPT(404.48,"AACXMIT",V4,"")) D Q ;
.. S ^TMP("SCMCLN2",$J,V1)=""
.. W !,"Pointer to HL7 EVENT file - the entry ("_V1_") was not deleted."
.S DA=V1
.D ^DIK
W !,"Clean-up completed",!
Q
CLEAN ;clean-up
K ^TMP("SCMCLN",$J)
K ^TMP("SCMCLN2",$J)
Q
W !,CNT1_" entries searched. Ghost entries found: "_CNT2
Q
TEST ;
S X=0 F S X=$O(^SCPT(404.48,X)) Q:'X D
. Q:($P(^SCPT(404.48,X,0),U,7)'[404.43)
. W ^SCPT(404.43,$P($P(^SCPT(404.48,X,0),U,7),";"),0),!
. Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCLN 2082 printed Nov 22, 2024@17:50:45 Page 2
SCMCLN ;swo/oifobp temp clean up routine
+1 ;;5.3;Scheduling;**498**;8.13.1993;Build 23
+2 ;lets clean-up danglers in 404.43 PATIENT TEAM POSITION ASSIGNMENT
+3 ;1st run thru 404.43 and find the pointers to 404.42 PATIENT TEAM ASSIGNMENT
+4 ;pointer is piece one of 404.43
+5 NEW CNT1,CNT2,DA,DIK,DIR,V1,V2,V3,V4,ZNODE
+6 SET (CNT1,CNT2)=0
+7 WRITE !,"Checking for ""Ghost Entries"" in the PATIENT TEAM POSITION ASSIGNMENT FILE."
+8 WRITE !,"This may take a moment. You will be provided with a list showing corrupted"
+9 WRITE !,"file entries. To perform a clean-up accept the ""Yes"" prompt after the list"
+10 WRITE !,"is displayed. Answer ""No"" to abort the clean-up.",!
+11 SET V1=0
FOR
SET V1=$ORDER(^SCPT(404.43,V1))
if 'V1
QUIT
Begin DoDot:1
+12 SET CNT1=CNT1+1
+13 SET ZNODE=$GET(^SCPT(404.43,V1,0))
+14 SET V2=$PIECE(ZNODE,U)
if V2=""
QUIT
+15 SET V3=$GET(^SCPT(404.42,V2,0))
IF V3=""
DO LOG
End DoDot:1
+16 DO SHOW
if POP
QUIT
+17 IF $GET(CNT2)<1
WRITE !,"Nothing to clean up...."
QUIT
+18 SET DIR("?")="Answerng Yes will perform a clean-up of the ghost entries"
+19 SET DIR("A")="Perform File Clean-Up"
+20 SET DIR(0)="Y"
SET DIR("B")="No"
DO ^DIR
+21 IF Y
DO DEL
+22 DO CLEAN
+23 QUIT
LOG ;build a list in ^TMP("SCMCLN",$J
+1 SET ^TMP("SCMCLN",$JOB,V1)=""
+2 SET CNT2=CNT2+1
+3 QUIT
SHOW ;see what we got
+1 SET DIOEND="D FOOT^SCMCLN"
+2 SET DIC="^SCPT(404.43,"
SET L=0
SET BY="@.03"
SET (FR,TO)=""
SET FLDS="[CAPTIONED]"
+3 SET BY(0)="^TMP(""SCMCLN"",$J,"
+4 SET L(0)=1
DO EN1^DIP
+5 QUIT
DEL ;delete the danglers
+1 ;check #404.48 -- PCMM HL7 EVENT FILE .07 field EVENT POINTER points to 404.43
+2 ;variable pointer, yeck!
+3 SET DIK="^SCPT(404.43,"
+4 SET V1=0
FOR
SET V1=$ORDER(^TMP("SCMCLN",$JOB,V1))
if 'V1
QUIT
Begin DoDot:1
+5 SET V4=""""_V1_";SCPT(404.43,"_""""
+6 ;
IF $ORDER(^SCPT(404.48,"AACXMIT",V4,""))
Begin DoDot:2
+7 SET ^TMP("SCMCLN2",$JOB,V1)=""
+8 WRITE !,"Pointer to HL7 EVENT file - the entry ("_V1_") was not deleted."
End DoDot:2
QUIT
+9 SET DA=V1
+10 DO ^DIK
End DoDot:1
+11 WRITE !,"Clean-up completed",!
+12 QUIT
CLEAN ;clean-up
+1 KILL ^TMP("SCMCLN",$JOB)
+2 KILL ^TMP("SCMCLN2",$JOB)
+3 QUIT
+1 WRITE !,CNT1_" entries searched. Ghost entries found: "_CNT2
+2 QUIT
TEST ;
+1 SET X=0
FOR
SET X=$ORDER(^SCPT(404.48,X))
if 'X
QUIT
Begin DoDot:1
+2 if ($PIECE(^SCPT(404.48,X,0),U,7)'[404.43)
QUIT
+3 WRITE ^SCPT(404.43,$PIECE($PIECE(^SCPT(404.48,X,0),U,7),";"),0),!
+4 QUIT
End DoDot:1
