PSOPOST7 ;BIR/EJW,JLC-Post install routine ;10/04/02
;;7.0;OUTPATIENT PHARMACY;**115,268**;DEC 1997;Build 9
;External reference to ^DPT supported by DBIA 10035
;External reference to ^PS(55 supported by DBIA 2228
; POST-INSTALL ROUTINE FOR PATCH PSO*7*115 - TO RESET MISSING ENTRIES INTO THE PHARMACY PATIENT FILE (#55)
S ZTDTH=""
I $D(ZTQUEUED) S ZTDTH=$H
L +^XTMP("PSOPOST7"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T D Q
. I ZTDTH="" W !,"Clean up job is already running. Halting..."
L -^XTMP("PSOPOST7")
I ZTDTH="" D
.W !,"The background job to search for missing ^PS(55 entries must be queued."
.W !,"If no start date/time is entered when prompted, the background job will be"
.W !,"queued to run NOW."
.W !
.D BMES^XPDUTL("Queuing background job to search for missing ^PS(55 entries")
S ZTRTN="RES^PSOPOST7",ZTIO="",ZTDESC="Background job to search for missing ^PS(55 entries" D ^%ZTLOAD K ZTDTH,ZTRTN,ZTIO,ZTDESC
W:$D(ZTSK)&('$D(ZTQUEUED)) !!,"Task Queued !",!
Q
RES ;
L +^XTMP("PSOPOST7"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T S:$D(ZTQUEUED) ZTREQ="@" Q
I '$G(DT) S DT=$$DT^XLFDT
I '$D(^XTMP("PSOPOST7")) S X1=DT,X2=+30 D C^%DTC S ^XTMP("PSOPOST7",0)=$G(X)_"^"_DT
S PSODT2=DT-20000
D NOW^%DTC S ^XTMP("PSOTIMEX","START")=%
D BMES^XPDUTL("Searching for missing ^PS(55 entries...")
SRCH ; SEARCH THROUGH PRESCRIPTIONS
N RXP,RX0,PSODFN,PSODT,PSOCTP,PSOCTPA
S (PSOCTP,PSOCTPA)=0
S RXP=0 F S RXP=$O(^PSRX(RXP)) Q:'RXP S RX0=$G(^PSRX(RXP,0)),PSODT=$P(RX0,"^",13) I PSODT>PSODT2 S PSODFN=$P(RX0,"^",2) I PSODFN D
.I '$D(^DPT(PSODFN,0)) Q
.D PS55P
.D PS55PA
I $O(^XTMP("PSOPOST7",$J,""))'="" D RESET
N DFN,PSJORD,PSSTART,PSSTOP,PSSTATUS,A
S DFN=0
F S DFN=$O(^PS(55,DFN)) Q:'DFN D
. S PSJORD=0 F S PSJORD=$O(^PS(55,DFN,5,PSJORD)) Q:'PSJORD D
.. S PSSTATUS=$P($G(^PS(55,DFN,5,PSJORD,0)),U,9),PSSTART=$P($G(^PS(55,DFN,5,PSJORD,2)),U,2),PSSTOP=$P($G(^(2)),U,4) I PSSTOP]"",$D(^PS(55,"AUD",PSSTOP,DFN,PSJORD)) Q
.. K DR S DIE="^PS(55,"_DFN_",5,",DA=PSJORD,DA(1)=DFN,DR="10////^S X=PSSTART;28////^S X=PSSTATUS;34////^S X=PSSTOP"
.. D ^DIE
.. S ^XTMP("PSOPOST7",$J,"UD",DFN,PSJORD)="" K DIE,DR,DA
. S PSJORD=0 F S PSJORD=$O(^PS(55,DFN,"IV",PSJORD)) Q:'PSJORD D
.. S A=$G(^PS(55,DFN,"IV",PSJORD,0)) Q:A=""
.. S PSSTART=$P(A,"^",2),PSSTOP=$P(A,"^",3),PSSTATUS=$P(A,"^",17)
.. I PSSTOP]"",$D(^PS(55,"AIV",PSSTOP,DFN,PSJORD)) Q
.. K DR S DIE="^PS(55,"_DFN_",""IV"",",DA=PSJORD,DA(1)=DFN,DR=".02////^S X=PSSTART;.03////^S X=PSSTOP;100////S X=PSSTATUS"
.. D ^DIE
.. S ^XTMP("PSOPOST7",$J,"IV",DFN,PSJORD)="" K DIE,DR,DA
MAIL ;
N CNT
D NOW^%DTC S PSOTIMEB=%
S Y=$G(^XTMP("PSOTIMEX","START")) D DD^%DT S PSOTIMEA=Y
S Y=$G(PSOTIMEB) D DD^%DT S PSOTIMEB=Y
S XMDUZ="Patch PSO*7*115",XMY(DUZ)="",XMSUB="PHARMACY PATIENT File (#55) search for missing entries"
K PSOTEXT S PSOTEXT(1)="Patch PSO*7*115 PHARMACY PATIENT File (#55) search and clean-up is complete.",PSOTEXT(2)="It started on "_$G(PSOTIMEA)_".",PSOTEXT(3)="It ended on "_$G(PSOTIMEB)_"."
S PSOTEXT(4)=" "
S PSOTEXT(5)=PSOCTP_" patients had missing ""P"" cross-references"_$S(PSOCTP>0:" and have been reset.",1:".")
S PSOTEXT(6)=PSOCTPA_" ^PS(55,PSODFN,""P"",""A"" cross-references were missing"_$S(PSOCTPA>0:" and have been reset.",1:".")
S PSOTEXT(7)=" "
S CNT=7
I PSOCTP S CNT=CNT+1,PSOTEXT(CNT)="The global ^XTMP(""PSOPOST7"","_$J_",PSODFN,ISSUE DATE,RXIEN) contains" D
.S CNT=CNT+1,PSOTEXT(CNT)="the missing ""P"" cross-reference entries. "_"("_$J_" is the job number.)"
S CNT=CNT+1,PSOTEXT(CNT)=" "
I PSOCTPA S CNT=CNT+1,PSOTEXT(CNT)="The global ^XTMP(""PSOPOST7"","_$J_",PSODFN,""P,A"",EXP. DATE,RXIEN) contains" D
.S CNT=CNT+1,PSOTEXT(CNT)="the missing ""P"",""A"" cross-reference entries. "_"("_$J_" is the job number.)"
I $D(^XTMP("PSOPOST7",$J,"UD")) D
. S CNT=CNT+1,PSOTEXT(CNT)="The global ^XTMP(""PSOPOST7"","_$J_",""UD"",DFN,PSJORD) contains"
. S CNT=CNT+1,PSOTEXT(CNT)="the unit dose orders missing stop dates."
I $D(^XTMP("PSOPOST7",$J,"IV")) D
. S CNT=CNT+1,PSOTEXT(CNT)="The global ^XTMP(""PSOPOST7"","_$J_",""IV"",DFN,PSJORD) contains"
. S CNT=CNT+1,PSOTEXT(CNT)="the IV orders missing stop dates."
S XMTEXT="PSOTEXT(" N DIFROM D ^XMD
K PSOTIMEA,PSOTIMEB,XMDUZ,XMSUB,PSOTEXT,XMTEXT,PSODT2
L -^XTMP("PSOPOST7")
S:$D(ZTQUEUED) ZTREQ="@"
Q
;
PS55P ; CHECK FOR MISSING "P" CROSS=REFERENCES
N PSOSQ
S PSOSQ=0 F S PSOSQ=$O(^PS(55,PSODFN,"P",PSOSQ)) Q:'PSOSQ I $G(^PS(55,PSODFN,"P",PSOSQ,0))=RXP Q
I PSOSQ Q
S ^XTMP("PSOPOST7",$J,PSODFN,PSODT,RXP)=""
Q
;
PS55PA ; CHECK FOR MISSING "P","A" CROSS-REFERENCES
N PSODT
S PSODT="" F S PSODT=$O(^PS(55,PSODFN,"P","A",PSODT)) Q:'PSODT I $D(^PS(55,PSODFN,"P","A",PSODT,RXP)) Q
I 'PSODT D
. N PSOEXP
. S PSOEXP=$P($G(^PSRX(RXP,2)),"^",6) I PSOEXP="" S PSOEXP=$P($G(^PSRX(RXP,3)),"^",5)
.I PSOEXP="" Q
.S ^XTMP("PSOPOST7",$J,PSODFN,"P,A",PSOEXP,RXP)=""
.D CHKPS
.S ^PS(55,PSODFN,"P","A",PSOEXP,RXP)="",PSOCTPA=PSOCTPA+1
Q
;
CHKPS ; SEE IF ^PS(55,PSODFN EXISTS - IF NOT SET TOP LEVEL AT LEAST
I '$D(^PS(55,PSODFN,0)) S ^PS(55,PSODFN,0)=PSODFN_"^^^^^2"
Q
;
RESET ; RESET "P" CROSS-REFERENCE BY BUILDING ^TMP GLOBAL IN ISSUE DATE SEQUENCE FOR ALL ENTRIES, THEN RESETTING THE "P" SUBSCRIPT
N PSOIDT,PSOSQ,CNT
S PSODFN="" F S PSODFN=$O(^XTMP("PSOPOST7",$J,PSODFN)) Q:'PSODFN S PSOCTP=PSOCTP+1 D
.K ^TMP("PSOPOST7",$J)
.S CNT=0
.I '$O(^XTMP("PSOPOST7",$J,PSODFN,"")) Q ; quit if only "P,A" entries
.L +^PS(55,PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
.S PSODT="" F S PSODT=$O(^XTMP("PSOPOST7",$J,PSODFN,PSODT)) Q:'PSODT S RXP="" F S RXP=$O(^XTMP("PSOPOST7",$J,PSODFN,PSODT,RXP)) Q:'RXP D
..S PSOIDT=$P($G(^PSRX(RXP,0)),"^",13) I PSOIDT'="" I '$D(^TMP("PSOPOST7",$J,PSOIDT,RXP)) S ^TMP("PSOPOST7",$J,PSOIDT,RXP)="",CNT=CNT+1
.S PSOSQ=0 F S PSOSQ=$O(^PS(55,PSODFN,"P",PSOSQ)) Q:'PSOSQ D ; NOW ADD ALL EXISTING ENRIES TO ^TMP GLOBAL
..S RXP=$G(^PS(55,PSODFN,"P",PSOSQ,0)) I RXP="" Q
..S PSOIDT=$P($G(^PSRX(RXP,0)),"^",13) I PSOIDT'="" I '$D(^TMP("PSOPOST7",$J,PSOIDT,RXP)) S ^TMP("PSOPOST7",$J,PSOIDT,RXP)="",CNT=CNT+1
.I $O(^PS(55,PSODFN,"P",CNT)) D
..S PSOSQ=CNT F S PSOSQ=$O(^PS(55,PSODFN,"P",PSOSQ)) Q:'PSOSQ K ^PS(55,PSODFN,"P",PSOSQ) ; REMOVE SEQUENCE NUMBERS THAT ARE GREATER THAN THE NUMBER OF "P" ENTRIES
.S CNT=0,PSOIDT="" F S PSOIDT=$O(^TMP("PSOPOST7",$J,PSOIDT)) Q:'PSOIDT S RXP="" F S RXP=$O(^TMP("PSOPOST7",$J,PSOIDT,RXP)) Q:'RXP S CNT=CNT+1,^PS(55,PSODFN,"P",CNT,0)=RXP
.I CNT>0 S ^PS(55,PSODFN,"P",0)="^55.03PA^"_CNT_"^"_CNT
.L -^PS(55,PSODFN)
K ^TMP("PSOPOST7",$J)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPOST7 6681 printed Oct 16, 2024@18:33:35 Page 2
PSOPOST7 ;BIR/EJW,JLC-Post install routine ;10/04/02
+1 ;;7.0;OUTPATIENT PHARMACY;**115,268**;DEC 1997;Build 9
+2 ;External reference to ^DPT supported by DBIA 10035
+3 ;External reference to ^PS(55 supported by DBIA 2228
+4 ; POST-INSTALL ROUTINE FOR PATCH PSO*7*115 - TO RESET MISSING ENTRIES INTO THE PHARMACY PATIENT FILE (#55)
+5 SET ZTDTH=""
+6 IF $DATA(ZTQUEUED)
SET ZTDTH=$HOROLOG
+7 LOCK +^XTMP("PSOPOST7"):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
Begin DoDot:1
+8 IF ZTDTH=""
WRITE !,"Clean up job is already running. Halting..."
End DoDot:1
QUIT
+9 LOCK -^XTMP("PSOPOST7")
+10 IF ZTDTH=""
Begin DoDot:1
+11 WRITE !,"The background job to search for missing ^PS(55 entries must be queued."
+12 WRITE !,"If no start date/time is entered when prompted, the background job will be"
+13 WRITE !,"queued to run NOW."
+14 WRITE !
+15 DO BMES^XPDUTL("Queuing background job to search for missing ^PS(55 entries")
End DoDot:1
+16 SET ZTRTN="RES^PSOPOST7"
SET ZTIO=""
SET ZTDESC="Background job to search for missing ^PS(55 entries"
DO ^%ZTLOAD
KILL ZTDTH,ZTRTN,ZTIO,ZTDESC
+17 if $DATA(ZTSK)&('$DATA(ZTQUEUED))
WRITE !!,"Task Queued !",!
+18 QUIT
RES ;
+1 LOCK +^XTMP("PSOPOST7"):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+2 IF '$GET(DT)
SET DT=$$DT^XLFDT
+3 IF '$DATA(^XTMP("PSOPOST7"))
SET X1=DT
SET X2=+30
DO C^%DTC
SET ^XTMP("PSOPOST7",0)=$GET(X)_"^"_DT
+4 SET PSODT2=DT-20000
+5 DO NOW^%DTC
SET ^XTMP("PSOTIMEX","START")=%
+6 DO BMES^XPDUTL("Searching for missing ^PS(55 entries...")
SRCH ; SEARCH THROUGH PRESCRIPTIONS
+1 NEW RXP,RX0,PSODFN,PSODT,PSOCTP,PSOCTPA
+2 SET (PSOCTP,PSOCTPA)=0
+3 SET RXP=0
FOR
SET RXP=$ORDER(^PSRX(RXP))
if 'RXP
QUIT
SET RX0=$GET(^PSRX(RXP,0))
SET PSODT=$PIECE(RX0,"^",13)
IF PSODT>PSODT2
SET PSODFN=$PIECE(RX0,"^",2)
IF PSODFN
Begin DoDot:1
+4 IF '$DATA(^DPT(PSODFN,0))
QUIT
+5 DO PS55P
+6 DO PS55PA
End DoDot:1
+7 IF $ORDER(^XTMP("PSOPOST7",$JOB,""))'=""
DO RESET
+8 NEW DFN,PSJORD,PSSTART,PSSTOP,PSSTATUS,A
+9 SET DFN=0
+10 FOR
SET DFN=$ORDER(^PS(55,DFN))
if 'DFN
QUIT
Begin DoDot:1
+11 SET PSJORD=0
FOR
SET PSJORD=$ORDER(^PS(55,DFN,5,PSJORD))
if 'PSJORD
QUIT
Begin DoDot:2
+12 SET PSSTATUS=$PIECE($GET(^PS(55,DFN,5,PSJORD,0)),U,9)
SET PSSTART=$PIECE($GET(^PS(55,DFN,5,PSJORD,2)),U,2)
SET PSSTOP=$PIECE($GET(^(2)),U,4)
IF PSSTOP]""
IF $DATA(^PS(55,"AUD",PSSTOP,DFN,PSJORD))
QUIT
+13 KILL DR
SET DIE="^PS(55,"_DFN_",5,"
SET DA=PSJORD
SET DA(1)=DFN
SET DR="10////^S X=PSSTART;28////^S X=PSSTATUS;34////^S X=PSSTOP"
+14 DO ^DIE
+15 SET ^XTMP("PSOPOST7",$JOB,"UD",DFN,PSJORD)=""
KILL DIE,DR,DA
End DoDot:2
+16 SET PSJORD=0
FOR
SET PSJORD=$ORDER(^PS(55,DFN,"IV",PSJORD))
if 'PSJORD
QUIT
Begin DoDot:2
+17 SET A=$GET(^PS(55,DFN,"IV",PSJORD,0))
if A=""
QUIT
+18 SET PSSTART=$PIECE(A,"^",2)
SET PSSTOP=$PIECE(A,"^",3)
SET PSSTATUS=$PIECE(A,"^",17)
+19 IF PSSTOP]""
IF $DATA(^PS(55,"AIV",PSSTOP,DFN,PSJORD))
QUIT
+20 KILL DR
SET DIE="^PS(55,"_DFN_",""IV"","
SET DA=PSJORD
SET DA(1)=DFN
SET DR=".02////^S X=PSSTART;.03////^S X=PSSTOP;100////S X=PSSTATUS"
+21 DO ^DIE
+22 SET ^XTMP("PSOPOST7",$JOB,"IV",DFN,PSJORD)=""
KILL DIE,DR,DA
End DoDot:2
End DoDot:1
MAIL ;
+1 NEW CNT
+2 DO NOW^%DTC
SET PSOTIMEB=%
+3 SET Y=$GET(^XTMP("PSOTIMEX","START"))
DO DD^%DT
SET PSOTIMEA=Y
+4 SET Y=$GET(PSOTIMEB)
DO DD^%DT
SET PSOTIMEB=Y
+5 SET XMDUZ="Patch PSO*7*115"
SET XMY(DUZ)=""
SET XMSUB="PHARMACY PATIENT File (#55) search for missing entries"
+6 KILL PSOTEXT
SET PSOTEXT(1)="Patch PSO*7*115 PHARMACY PATIENT File (#55) search and clean-up is complete."
SET PSOTEXT(2)="It started on "_$GET(PSOTIMEA)_"."
SET PSOTEXT(3)="It ended on "_$GET(PSOTIMEB)_"."
+7 SET PSOTEXT(4)=" "
+8 SET PSOTEXT(5)=PSOCTP_" patients had missing ""P"" cross-references"_$SELECT(PSOCTP>0:" and have been reset.",1:".")
+9 SET PSOTEXT(6)=PSOCTPA_" ^PS(55,PSODFN,""P"",""A"" cross-references were missing"_$SELECT(PSOCTPA>0:" and have been reset.",1:".")
+10 SET PSOTEXT(7)=" "
+11 SET CNT=7
+12 IF PSOCTP
SET CNT=CNT+1
SET PSOTEXT(CNT)="The global ^XTMP(""PSOPOST7"","_$JOB_",PSODFN,ISSUE DATE,RXIEN) contains"
Begin DoDot:1
+13 SET CNT=CNT+1
SET PSOTEXT(CNT)="the missing ""P"" cross-reference entries. "_"("_$JOB_" is the job number.)"
End DoDot:1
+14 SET CNT=CNT+1
SET PSOTEXT(CNT)=" "
+15 IF PSOCTPA
SET CNT=CNT+1
SET PSOTEXT(CNT)="The global ^XTMP(""PSOPOST7"","_$JOB_",PSODFN,""P,A"",EXP. DATE,RXIEN) contains"
Begin DoDot:1
+16 SET CNT=CNT+1
SET PSOTEXT(CNT)="the missing ""P"",""A"" cross-reference entries. "_"("_$JOB_" is the job number.)"
End DoDot:1
+17 IF $DATA(^XTMP("PSOPOST7",$JOB,"UD"))
Begin DoDot:1
+18 SET CNT=CNT+1
SET PSOTEXT(CNT)="The global ^XTMP(""PSOPOST7"","_$JOB_",""UD"",DFN,PSJORD) contains"
+19 SET CNT=CNT+1
SET PSOTEXT(CNT)="the unit dose orders missing stop dates."
End DoDot:1
+20 IF $DATA(^XTMP("PSOPOST7",$JOB,"IV"))
Begin DoDot:1
+21 SET CNT=CNT+1
SET PSOTEXT(CNT)="The global ^XTMP(""PSOPOST7"","_$JOB_",""IV"",DFN,PSJORD) contains"
+22 SET CNT=CNT+1
SET PSOTEXT(CNT)="the IV orders missing stop dates."
End DoDot:1
+23 SET XMTEXT="PSOTEXT("
NEW DIFROM
DO ^XMD
+24 KILL PSOTIMEA,PSOTIMEB,XMDUZ,XMSUB,PSOTEXT,XMTEXT,PSODT2
+25 LOCK -^XTMP("PSOPOST7")
+26 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+27 QUIT
+28 ;
PS55P ; CHECK FOR MISSING "P" CROSS=REFERENCES
+1 NEW PSOSQ
+2 SET PSOSQ=0
FOR
SET PSOSQ=$ORDER(^PS(55,PSODFN,"P",PSOSQ))
if 'PSOSQ
QUIT
IF $GET(^PS(55,PSODFN,"P",PSOSQ,0))=RXP
QUIT
+3 IF PSOSQ
QUIT
+4 SET ^XTMP("PSOPOST7",$JOB,PSODFN,PSODT,RXP)=""
+5 QUIT
+6 ;
PS55PA ; CHECK FOR MISSING "P","A" CROSS-REFERENCES
+1 NEW PSODT
+2 SET PSODT=""
FOR
SET PSODT=$ORDER(^PS(55,PSODFN,"P","A",PSODT))
if 'PSODT
QUIT
IF $DATA(^PS(55,PSODFN,"P","A",PSODT,RXP))
QUIT
+3 IF 'PSODT
Begin DoDot:1
+4 NEW PSOEXP
+5 SET PSOEXP=$PIECE($GET(^PSRX(RXP,2)),"^",6)
IF PSOEXP=""
SET PSOEXP=$PIECE($GET(^PSRX(RXP,3)),"^",5)
+6 IF PSOEXP=""
QUIT
+7 SET ^XTMP("PSOPOST7",$JOB,PSODFN,"P,A",PSOEXP,RXP)=""
+8 DO CHKPS
+9 SET ^PS(55,PSODFN,"P","A",PSOEXP,RXP)=""
SET PSOCTPA=PSOCTPA+1
End DoDot:1
+10 QUIT
+11 ;
CHKPS ; SEE IF ^PS(55,PSODFN EXISTS - IF NOT SET TOP LEVEL AT LEAST
+1 IF '$DATA(^PS(55,PSODFN,0))
SET ^PS(55,PSODFN,0)=PSODFN_"^^^^^2"
+2 QUIT
+3 ;
RESET ; RESET "P" CROSS-REFERENCE BY BUILDING ^TMP GLOBAL IN ISSUE DATE SEQUENCE FOR ALL ENTRIES, THEN RESETTING THE "P" SUBSCRIPT
+1 NEW PSOIDT,PSOSQ,CNT
+2 SET PSODFN=""
FOR
SET PSODFN=$ORDER(^XTMP("PSOPOST7",$JOB,PSODFN))
if 'PSODFN
QUIT
SET PSOCTP=PSOCTP+1
Begin DoDot:1
+3 KILL ^TMP("PSOPOST7",$JOB)
+4 SET CNT=0
+5 ; quit if only "P,A" entries
IF '$ORDER(^XTMP("PSOPOST7",$JOB,PSODFN,""))
QUIT
+6 LOCK +^PS(55,PSODFN):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
+7 SET PSODT=""
FOR
SET PSODT=$ORDER(^XTMP("PSOPOST7",$JOB,PSODFN,PSODT))
if 'PSODT
QUIT
SET RXP=""
FOR
SET RXP=$ORDER(^XTMP("PSOPOST7",$JOB,PSODFN,PSODT,RXP))
if 'RXP
QUIT
Begin DoDot:2
+8 SET PSOIDT=$PIECE($GET(^PSRX(RXP,0)),"^",13)
IF PSOIDT'=""
IF '$DATA(^TMP("PSOPOST7",$JOB,PSOIDT,RXP))
SET ^TMP("PSOPOST7",$JOB,PSOIDT,RXP)=""
SET CNT=CNT+1
End DoDot:2
+9 ; NOW ADD ALL EXISTING ENRIES TO ^TMP GLOBAL
SET PSOSQ=0
FOR
SET PSOSQ=$ORDER(^PS(55,PSODFN,"P",PSOSQ))
if 'PSOSQ
QUIT
Begin DoDot:2
+10 SET RXP=$GET(^PS(55,PSODFN,"P",PSOSQ,0))
IF RXP=""
QUIT
+11 SET PSOIDT=$PIECE($GET(^PSRX(RXP,0)),"^",13)
IF PSOIDT'=""
IF '$DATA(^TMP("PSOPOST7",$JOB,PSOIDT,RXP))
SET ^TMP("PSOPOST7",$JOB,PSOIDT,RXP)=""
SET CNT=CNT+1
End DoDot:2
+12 IF $ORDER(^PS(55,PSODFN,"P",CNT))
Begin DoDot:2
+13 ; REMOVE SEQUENCE NUMBERS THAT ARE GREATER THAN THE NUMBER OF "P" ENTRIES
SET PSOSQ=CNT
FOR
SET PSOSQ=$ORDER(^PS(55,PSODFN,"P",PSOSQ))
if 'PSOSQ
QUIT
KILL ^PS(55,PSODFN,"P",PSOSQ)
End DoDot:2
+14 SET CNT=0
SET PSOIDT=""
FOR
SET PSOIDT=$ORDER(^TMP("PSOPOST7",$JOB,PSOIDT))
if 'PSOIDT
QUIT
SET RXP=""
FOR
SET RXP=$ORDER(^TMP("PSOPOST7",$JOB,PSOIDT,RXP))
if 'RXP
QUIT
SET CNT=CNT+1
SET ^PS(55,PSODFN,"P",CNT,0)=RXP
+15 IF CNT>0
SET ^PS(55,PSODFN,"P",0)="^55.03PA^"_CNT_"^"_CNT
+16 LOCK -^PS(55,PSODFN)
End DoDot:1
+17 KILL ^TMP("PSOPOST7",$JOB)
+18 QUIT
+19 ;
