SCMCLN.m

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

FOOT ;footer message

 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 ---SCMCLN   2082     printed  Mar 13, 2025@21:45:43                                                                                                                                                                                                      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 

FOOT      ;footer message

 +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