PSO7P731 ;DAL/JCH - Post Install routine for patch PSO*7*731 ;08/24/2023
;;7.0;OUTPATIENT PHARMACY;**731**;DEC 1997;Build 18
;
; Reference to ^VA(200,IEN,"PS" in ICR #10060
Q
;
POST ; Post Install queued entry point
D QUE
Q
;
START ; Begin post-install processing
; Remove orphaned DEAs
N PSOXNODE
S PSOXNODE="PSO*7.0*731 POST INSTALL"
D ORPHANDEA
D TMPMSG(PSOXNODE)
Q
;
ORPHANDEA ; Clean up orphaned DEA# field (53.2) in NEW PERSON file (#200)
N DEA532,DEA5321,PRIEN,PSOFDA,PSOPRGDT,PSOXHDR,PSODTM
S PSODTM=$$NOW^XLFDT()
S PSOXHDR=$$FMADD^XLFDT($$DT^XLFDT(),90)_"^"_$$DT^XLFDT()_"^Delete orphan DEA numbers from DEA# field (#53.2) in NEW PERSON file (#200)"
S ^XTMP(PSOXNODE,0)=$G(PSOXHDR)
;
; Remove Orphan DEA# field (#53.2) values when no NEW DEA #'s multiple (#53.21) values exist for Provider
; Find all DEA number in DEA# field (#53.2)
S DEA532="" F S DEA532=$O(^VA(200,"PS1",DEA532)) Q:DEA532="" D
. ; Find providers associated with DEA# - quit if no NEW DEA #'s were ever filed for the provider
. S PRIEN=0 F S PRIEN=$O(^VA(200,"PS1",DEA532,PRIEN)) Q:'PRIEN D
. . Q:'$D(^VA(200,PRIEN,"PS4",0))!$O(^VA(200,PRIEN,"PS4",0))
. . K PSOFDA,PSOERR
. . S PSOFDA(200,PRIEN_",",53.2)="@"
. . D FILE^DIE("","PSOFDA","PSOERR")
. . S ^XTMP(PSOXNODE,"DEA",$G(DEA532),"DELETED",+$G(PRIEN))=PSODTM
. . S PSOERR=$G(PSOERR("DIERR",1,"TEXT",1)) I $L(PSOERR) S ^XTMP(PSOXNODE,"DEA",$G(DEA532),"ERROR",+$G(PRIEN))=""
. . Q
. Q
Q
;
TMPMSG(PSOXNODE) ; Send MailMan LOG REPORT
Q:$G(PSOXNODE)=""
N PSODASH,PSOXMAIL,PSODEA,PSOPRIEN,PSOCNT,PSODEAR,PSOPAD,NPIEN,XMDUZ,XMSUB
S $P(PSODASH,"-",80)="",$P(PSOPAD," ",80)=" "
S PSOXMAIL="PSO_ORPHAN_DEA_CLEANUP"
S XMDUZ=.5
;
S XMSUB="Orphan DEA Cleanup Complete "_$$FMTE^XLFDT(DT,"5DZ"),XMDUZ=.5
K XMY S NPIEN=0 F S NPIEN=$O(^XUSEC("PSDMGR",NPIEN)) Q:'+NPIEN S XMY(NPIEN)=""
;
S PSOCNT=3 ; Start DEA array starts at 4, first 3 lines for header
S PSODEA="" F S PSODEA=$O(^XTMP(PSOXNODE,"DEA",PSODEA)) Q:PSODEA="" D
. S PSOPRIEN=0 F S PSOPRIEN=$O(^XTMP(PSOXNODE,"DEA",PSODEA,"DELETED",PSOPRIEN)) Q:'PSOPRIEN D
. . ; Pull Date/Time back out, in case run more than once at different times
. . S PSODTM=$G(^XTMP(PSOXNODE,"DEA",PSODEA,"DELETED",PSOPRIEN)) S:'$L(PSODTM) PSODTM="*Missing*"
. . S PSOCNT=PSOCNT+1
. . S PSODEAR(PSOCNT,0)=" Provider IEN:"_PSOPRIEN
. . S PSODEAR(PSOCNT,0)=PSODEAR(PSOCNT,0)_$E(PSOPAD,1,31-$L(PSODEAR(PSOCNT,0)))_" DEA: "_PSODEA_" Removed: "_$P($$FMTE^XLFDT(PSODTM,"2Z"),":",1,2)
S PSOCNT=PSOCNT-3
;
S ^XTMP(PSOXMAIL,$J,1,0)=" Orphan DEA Cleanup Complete"
S ^XTMP(PSOXMAIL,$J,2,0)=" "_PSOCNT_" orphaned DEA number"_$S(PSOCNT=1:" was ",1:"s were ")_"removed from the NEW PERSON (#200) file"
S ^XTMP(PSOXMAIL,$J,3,0)=""
M ^XTMP(PSOXMAIL,$J)=PSODEAR
;
S XMY(DUZ)="" N DIFROM S XMTEXT="^XTMP("""_PSOXMAIL_""","_$J_"," D ^XMD K DIFROM
K PSOTEXT,XMTEXT
K ^XTMP(PSOXMAIL,$J)
Q
;
QUE ; Que post install
N PSOJOB,PSOPATCH,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTQUEUED,ZTREQ,ZTSAVE
S PSOPATCH="PSO*7.0*731"
S ZTDTH=$$FMTH^XLFDT($$NOW^XLFDT())
S PSOJOB=$J
;
S ZTRTN="START^PSO7P731",ZTIO=""
S (ZTDESC)="Background job for "_PSOJOB
S ZTSAVE("JOBN")="",ZTSAVE("ZTDTH")="",ZTSAVE("DUZ")=""
D ^%ZTLOAD
D:$D(ZTSK)
. N POSTEXT
. S POSTEXT(1)="A MailMan message will be sent to the installer and"
. S POSTEXT(2)="PSDRPH key holders upon Post Install Completion"
. S POSTEXT(3)="*** Task #"_ZTSK_" Queued! ***"
. D MES^XPDUTL(.POSTEXT)
. S ZTSAVE("ZTSK")=""
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO7P731 3567 printed Sep 23, 2025@20:00:13 Page 2
PSO7P731 ;DAL/JCH - Post Install routine for patch PSO*7*731 ;08/24/2023
+1 ;;7.0;OUTPATIENT PHARMACY;**731**;DEC 1997;Build 18
+2 ;
+3 ; Reference to ^VA(200,IEN,"PS" in ICR #10060
+4 QUIT
+5 ;
POST ; Post Install queued entry point
+1 DO QUE
+2 QUIT
+3 ;
START ; Begin post-install processing
+1 ; Remove orphaned DEAs
+2 NEW PSOXNODE
+3 SET PSOXNODE="PSO*7.0*731 POST INSTALL"
+4 DO ORPHANDEA
+5 DO TMPMSG(PSOXNODE)
+6 QUIT
+7 ;
ORPHANDEA ; Clean up orphaned DEA# field (53.2) in NEW PERSON file (#200)
+1 NEW DEA532,DEA5321,PRIEN,PSOFDA,PSOPRGDT,PSOXHDR,PSODTM
+2 SET PSODTM=$$NOW^XLFDT()
+3 SET PSOXHDR=$$FMADD^XLFDT($$DT^XLFDT(),90)_"^"_$$DT^XLFDT()_"^Delete orphan DEA numbers from DEA# field (#53.2) in NEW PERSON file (#200)"
+4 SET ^XTMP(PSOXNODE,0)=$GET(PSOXHDR)
+5 ;
+6 ; Remove Orphan DEA# field (#53.2) values when no NEW DEA #'s multiple (#53.21) values exist for Provider
+7 ; Find all DEA number in DEA# field (#53.2)
+8 SET DEA532=""
FOR
SET DEA532=$ORDER(^VA(200,"PS1",DEA532))
if DEA532=""
QUIT
Begin DoDot:1
+9 ; Find providers associated with DEA# - quit if no NEW DEA #'s were ever filed for the provider
+10 SET PRIEN=0
FOR
SET PRIEN=$ORDER(^VA(200,"PS1",DEA532,PRIEN))
if 'PRIEN
QUIT
Begin DoDot:2
+11 if '$DATA(^VA(200,PRIEN,"PS4",0))!$ORDER(^VA(200,PRIEN,"PS4",0))
QUIT
+12 KILL PSOFDA,PSOERR
+13 SET PSOFDA(200,PRIEN_",",53.2)="@"
+14 DO FILE^DIE("","PSOFDA","PSOERR")
+15 SET ^XTMP(PSOXNODE,"DEA",$GET(DEA532),"DELETED",+$GET(PRIEN))=PSODTM
+16 SET PSOERR=$GET(PSOERR("DIERR",1,"TEXT",1))
IF $LENGTH(PSOERR)
SET ^XTMP(PSOXNODE,"DEA",$GET(DEA532),"ERROR",+$GET(PRIEN))=""
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
TMPMSG(PSOXNODE) ; Send MailMan LOG REPORT
+1 if $GET(PSOXNODE)=""
QUIT
+2 NEW PSODASH,PSOXMAIL,PSODEA,PSOPRIEN,PSOCNT,PSODEAR,PSOPAD,NPIEN,XMDUZ,XMSUB
+3 SET $PIECE(PSODASH,"-",80)=""
SET $PIECE(PSOPAD," ",80)=" "
+4 SET PSOXMAIL="PSO_ORPHAN_DEA_CLEANUP"
+5 SET XMDUZ=.5
+6 ;
+7 SET XMSUB="Orphan DEA Cleanup Complete "_$$FMTE^XLFDT(DT,"5DZ")
SET XMDUZ=.5
+8 KILL XMY
SET NPIEN=0
FOR
SET NPIEN=$ORDER(^XUSEC("PSDMGR",NPIEN))
if '+NPIEN
QUIT
SET XMY(NPIEN)=""
+9 ;
+10 ; Start DEA array starts at 4, first 3 lines for header
SET PSOCNT=3
+11 SET PSODEA=""
FOR
SET PSODEA=$ORDER(^XTMP(PSOXNODE,"DEA",PSODEA))
if PSODEA=""
QUIT
Begin DoDot:1
+12 SET PSOPRIEN=0
FOR
SET PSOPRIEN=$ORDER(^XTMP(PSOXNODE,"DEA",PSODEA,"DELETED",PSOPRIEN))
if 'PSOPRIEN
QUIT
Begin DoDot:2
+13 ; Pull Date/Time back out, in case run more than once at different times
+14 SET PSODTM=$GET(^XTMP(PSOXNODE,"DEA",PSODEA,"DELETED",PSOPRIEN))
if '$LENGTH(PSODTM)
SET PSODTM="*Missing*"
+15 SET PSOCNT=PSOCNT+1
+16 SET PSODEAR(PSOCNT,0)=" Provider IEN:"_PSOPRIEN
+17 SET PSODEAR(PSOCNT,0)=PSODEAR(PSOCNT,0)_$EXTRACT(PSOPAD,1,31-$LENGTH(PSODEAR(PSOCNT,0)))_" DEA: "_PSODEA_" Removed: "_$PIECE($$FMTE^XLFDT(PSODTM,"2Z"),":",1,2)
End DoDot:2
End DoDot:1
+18 SET PSOCNT=PSOCNT-3
+19 ;
+20 SET ^XTMP(PSOXMAIL,$JOB,1,0)=" Orphan DEA Cleanup Complete"
+21 SET ^XTMP(PSOXMAIL,$JOB,2,0)=" "_PSOCNT_" orphaned DEA number"_$SELECT(PSOCNT=1:" was ",1:"s were ")_"removed from the NEW PERSON (#200) file"
+22 SET ^XTMP(PSOXMAIL,$JOB,3,0)=""
+23 MERGE ^XTMP(PSOXMAIL,$JOB)=PSODEAR
+24 ;
+25 SET XMY(DUZ)=""
NEW DIFROM
SET XMTEXT="^XTMP("""_PSOXMAIL_""","_$JOB_","
DO ^XMD
KILL DIFROM
+26 KILL PSOTEXT,XMTEXT
+27 KILL ^XTMP(PSOXMAIL,$JOB)
+28 QUIT
+29 ;
QUE ; Que post install
+1 NEW PSOJOB,PSOPATCH,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,ZTQUEUED,ZTREQ,ZTSAVE
+2 SET PSOPATCH="PSO*7.0*731"
+3 SET ZTDTH=$$FMTH^XLFDT($$NOW^XLFDT())
+4 SET PSOJOB=$JOB
+5 ;
+6 SET ZTRTN="START^PSO7P731"
SET ZTIO=""
+7 SET (ZTDESC)="Background job for "_PSOJOB
+8 SET ZTSAVE("JOBN")=""
SET ZTSAVE("ZTDTH")=""
SET ZTSAVE("DUZ")=""
+9 DO ^%ZTLOAD
+10 if $DATA(ZTSK)
Begin DoDot:1
+11 NEW POSTEXT
+12 SET POSTEXT(1)="A MailMan message will be sent to the installer and"
+13 SET POSTEXT(2)="PSDRPH key holders upon Post Install Completion"
+14 SET POSTEXT(3)="*** Task #"_ZTSK_" Queued! ***"
+15 DO MES^XPDUTL(.POSTEXT)
+16 SET ZTSAVE("ZTSK")=""
End DoDot:1
+17 ;
+18 QUIT
