- 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
- ;
- 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 ;
