- PSOPOS10 ;BIR/VRN/EJW/MFR Post install routine ;10/14/03
- ;;7.0;OUTPATIENT PHARMACY;**154**;DEC 1997
- ;External reference to ^DPT supported by DBIA 10035
- ;External reference to ^PS(55 supported by DBIA 2228
- ;External reference to ^DPT(PSODFN,-9) supported by DBIA 2762
- ;
- ; POST-INSTALL ROUTINE TO RESET MISSING ENTRIES INTO THE PHARMACY PATIENT FILE (#55)
- ;
- ENV ;
- Q:'$G(XPDENV)
- W ! K %DT D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("A")="Queue the Post-Install to run at what Date@Time: "
- D ^%DT K %DT I $D(DTOUT)!(Y<0) W !!,"Cannot install the patch without queuing the post-install, install aborted!",! S XPDABORT=2 Q
- S @XPDGREF@("PSOQ10")=Y
- Q
- ;
- EN ;
- S ZTDTH=@XPDGREF@("PSOQ10")
- S ZTRTN="START^PSOPOS10",ZTDESC="Background job for to search for missing ^PS(55 entries",ZTIO="" D ^%ZTLOAD K ZTDTH,ZTRTN,ZTIO,ZTDESC
- I $D(ZTSK)&('$D(ZTQUEUED)) D BMES^XPDUTL("Task Queued!")
- Q
- ;
- START ;
- K ^XTMP("PSOPOS10",$J)
- L +^XTMP("PSOPOS10"):0 I '$T S:$D(ZTQUEUED) ZTREQ="@" Q
- I '$G(DT) S DT=$$DT^XLFDT
- I '$D(^XTMP("PSOPOS10")) S X1=DT,X2=+90 D C^%DTC S ^XTMP("PSOPOS10",0)=$G(X)_"^"_DT
- S PSODT2=DT-20000
- D NOW^%DTC S ^XTMP("PSOPOS10","PSOTIMEX","START")=%
- D BMES^XPDUTL("Searching for missing ^PS(55 entries... Sending Mailman message upon completion.")
- 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
- .D PS55P
- .D PS55PA
- .I $D(^DPT(PSODFN,-9)) D
- ..S NEWDFN=+$G(^DPT(PSODFN,-9)) I '$D(^DPT(NEWDFN,0)) Q
- ..D FIX^PSOPOS12(PSODFN,NEWDFN)
- I $O(^XTMP("PSOPOS10",$J,""))'="" D RESET
- L -^XTMP("PSOPOS10")
- D GETLIST
- MAIL ;
- N CNT
- D NOW^%DTC S PSOTIMEB=%
- S Y=$G(^XTMP("PSOPOS10","PSOTIMEX","START")) D DD^%DT S PSOTIMEA=Y
- S Y=$G(PSOTIMEB) D DD^%DT S PSOTIMEB=Y
- S XMDUZ="Patch PSO*7*154",XMY(DUZ)="",XMSUB="PHARMACY PATIENT File (#55) missing entries"
- K PSOTEXT S PSOTEXT(1)="Patch PSO*7*154 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 CNT=4
- S NAM="" F S NAM=$O(^TMP($J,"PSOPOS11",NAM)) Q:NAM="" D
- .S DFN="" F S DFN=$O(^TMP($J,"PSOPOS11",NAM,DFN)) Q:DFN="" D
- ..D GETPT S CNT=CNT+1,PSOTEXT(CNT)=" ",CNT=CNT+1,PSOTEXT(CNT)=PSOTXT
- ..S PSOSQ="" F S PSOSQ=$O(^TMP($J,"PSOPOS11",NAM,DFN,PSOSQ)) Q:PSOSQ="" D
- ...I PSOSQ="P" S PSORX="" F S PSORX=$O(^TMP($J,"PSOPOS11",NAM,DFN,PSOSQ,PSORX)) Q:PSORX="" S CNT=CNT+1 S PSOTEXT(CNT)=" ""P"" CROSS-REFERENCE REBUILT FOR RX#: "_PSORX
- ...I PSOSQ="P,A" S PSORX="" F S PSORX=$O(^TMP($J,"PSOPOS11",NAM,DFN,PSOSQ,PSORX)) Q:PSORX="" S CNT=CNT+1 S PSOTEXT(CNT)=" ""P"",""A"" CROSS-REFERENCE REBUILT FOR RX#: "_PSORX
- I CNT=4 S CNT=CNT+1,PSOTEXT(CNT)="No missing Cross References"
- S CNT=CNT+1,PSOTEXT(CNT)=" ",PSOTEXT(CNT+1)="** END OF LIST **"
- S XMTEXT="PSOTEXT(" N DIFROM D ^XMD
- K PSOTIMEA,PSOTIMEB,XMDUZ,XMSUB,PSOTEXT,XMTEXT,PSODT2,^TMP($J,"PSOPOS11"),CNT,DFN,MSG,NAM,PSODT,PSOJOB,PSOSQ,PSOSQ1,PSOTXT
- 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("PSOPOS10",$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("PSOPOS10",$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)) D
- .;S ^PS(55,PSODFN,0)=PSODFN_"^^^^^2"
- .L +^PS(55,PSODFN)
- .S PSOUPD=2
- .K DIC S DIC="^PS(55,",DIC(0)="L",(X,DINUM)=PSODFN,DIC("DR")="52.1///"_PSOUPD
- .K DD,DO D FILE^DICN K DD,DO,DIE,X,DINUM
- .L -^PS(55,PSODFN)
- 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("PSOPOS10",$J,PSODFN)) Q:'PSODFN S PSOCTP=PSOCTP+1 D
- .K ^TMP("PSOPOS10",$J)
- .S CNT=0
- .I '$O(^XTMP("PSOPOS10",$J,PSODFN,"")) Q ; quit if only "P,A" entries
- .L +^PS(55,PSODFN)
- .S PSODT="" F S PSODT=$O(^XTMP("PSOPOS10",$J,PSODFN,PSODT)) Q:'PSODT S RXP="" F S RXP=$O(^XTMP("PSOPOS10",$J,PSODFN,PSODT,RXP)) Q:'RXP D
- ..S PSOIDT=$P($G(^PSRX(RXP,0)),"^",13) I PSOIDT'="" I '$D(^TMP("PSOPOS10",$J,PSOIDT,RXP)) S ^TMP("PSOPOS10",$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("PSOPOS10",$J,PSOIDT,RXP)) S ^TMP("PSOPOS10",$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("PSOPOS10",$J,PSOIDT)) Q:'PSOIDT S RXP="" F S RXP=$O(^TMP("PSOPOS10",$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("PSOPOS10",$J)
- Q
- ;
- GETLIST ; PROCESS ENTRIES FROM ^XTMP("PSOPOS10" GLOBAL
- K ^TMP($J,"PSOPOS11")
- S PSOJOB="" F S PSOJOB=$O(^XTMP("PSOPOS10",PSOJOB)) Q:PSOJOB="" D
- .S PSOSQ="" F S PSOSQ=$O(^XTMP("PSOPOS10",PSOJOB,PSOSQ)) Q:PSOSQ="" D
- ..S NAM=$P($G(^DPT(PSOSQ,0)),"^",1) I NAM="" S NAM="UNKNOWN"
- ..S PSOSQ1="" F S PSOSQ1=$O(^XTMP("PSOPOS10",PSOJOB,PSOSQ,PSOSQ1)) Q:PSOSQ1="" D
- ...I PSOSQ1="P,A" D GETPA Q
- ...S PSORX="" F S PSORX=$O(^XTMP("PSOPOS10",PSOJOB,PSOSQ,PSOSQ1,PSORX)) Q:PSORX="" S PSORXP=$P($G(^PSRX(PSORX,0)),"^",1) I PSORXP'="" S ^TMP($J,"PSOPOS11",NAM,PSOSQ,"P",PSORXP)=""
- Q
- ;
- GETPT ; GET PATIENT INFORMATION
- D PID^VADPT
- S PSOTXT=$P($G(^DPT(DFN,0)),"^",1)_" ("_$G(VA("BID"))_")"
- Q
- ;
- GETPA ;
- S PSODT="" F S PSODT=$O(^XTMP("PSOPOS10",PSOJOB,PSOSQ,PSOSQ1,PSODT)) Q:PSODT="" D
- .S PSORX="" F S PSORX=$O(^XTMP("PSOPOS10",PSOJOB,PSOSQ,PSOSQ1,PSODT,PSORX)) Q:PSORX="" S PSORXP=$P($G(^PSRX(PSORX,0)),"^",1) I PSORXP'="" S ^TMP($J,"PSOPOS11",NAM,PSOSQ,"P,A",PSORXP)=""
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPOS10 6599 printed Feb 18, 2025@23:59:14 Page 2
- PSOPOS10 ;BIR/VRN/EJW/MFR Post install routine ;10/14/03
- +1 ;;7.0;OUTPATIENT PHARMACY;**154**;DEC 1997
- +2 ;External reference to ^DPT supported by DBIA 10035
- +3 ;External reference to ^PS(55 supported by DBIA 2228
- +4 ;External reference to ^DPT(PSODFN,-9) supported by DBIA 2762
- +5 ;
- +6 ; POST-INSTALL ROUTINE TO RESET MISSING ENTRIES INTO THE PHARMACY PATIENT FILE (#55)
- +7 ;
- ENV ;
- +1 if '$GET(XPDENV)
- QUIT
- +2 WRITE !
- KILL %DT
- DO NOW^%DTC
- SET %DT="RAEX"
- SET %DT(0)=%
- SET %DT("A")="Queue the Post-Install to run at what Date@Time: "
- +3 DO ^%DT
- KILL %DT
- IF $DATA(DTOUT)!(Y<0)
- WRITE !!,"Cannot install the patch without queuing the post-install, install aborted!",!
- SET XPDABORT=2
- QUIT
- +4 SET @XPDGREF@("PSOQ10")=Y
- +5 QUIT
- +6 ;
- EN ;
- +1 SET ZTDTH=@XPDGREF@("PSOQ10")
- +2 SET ZTRTN="START^PSOPOS10"
- SET ZTDESC="Background job for to search for missing ^PS(55 entries"
- SET ZTIO=""
- DO ^%ZTLOAD
- KILL ZTDTH,ZTRTN,ZTIO,ZTDESC
- +3 IF $DATA(ZTSK)&('$DATA(ZTQUEUED))
- DO BMES^XPDUTL("Task Queued!")
- +4 QUIT
- +5 ;
- START ;
- +1 KILL ^XTMP("PSOPOS10",$JOB)
- +2 LOCK +^XTMP("PSOPOS10"):0
- IF '$TEST
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- +3 IF '$GET(DT)
- SET DT=$$DT^XLFDT
- +4 IF '$DATA(^XTMP("PSOPOS10"))
- SET X1=DT
- SET X2=+90
- DO C^%DTC
- SET ^XTMP("PSOPOS10",0)=$GET(X)_"^"_DT
- +5 SET PSODT2=DT-20000
- +6 DO NOW^%DTC
- SET ^XTMP("PSOPOS10","PSOTIMEX","START")=%
- +7 DO BMES^XPDUTL("Searching for missing ^PS(55 entries... Sending Mailman message upon completion.")
- 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 DO PS55P
- +5 DO PS55PA
- +6 IF $DATA(^DPT(PSODFN,-9))
- Begin DoDot:2
- +7 SET NEWDFN=+$GET(^DPT(PSODFN,-9))
- IF '$DATA(^DPT(NEWDFN,0))
- QUIT
- +8 DO FIX^PSOPOS12(PSODFN,NEWDFN)
- End DoDot:2
- End DoDot:1
- +9 IF $ORDER(^XTMP("PSOPOS10",$JOB,""))'=""
- DO RESET
- +10 LOCK -^XTMP("PSOPOS10")
- +11 DO GETLIST
- MAIL ;
- +1 NEW CNT
- +2 DO NOW^%DTC
- SET PSOTIMEB=%
- +3 SET Y=$GET(^XTMP("PSOPOS10","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*154"
- SET XMY(DUZ)=""
- SET XMSUB="PHARMACY PATIENT File (#55) missing entries"
- +6 KILL PSOTEXT
- SET PSOTEXT(1)="Patch PSO*7*154 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 CNT=4
- +9 SET NAM=""
- FOR
- SET NAM=$ORDER(^TMP($JOB,"PSOPOS11",NAM))
- if NAM=""
- QUIT
- Begin DoDot:1
- +10 SET DFN=""
- FOR
- SET DFN=$ORDER(^TMP($JOB,"PSOPOS11",NAM,DFN))
- if DFN=""
- QUIT
- Begin DoDot:2
- +11 DO GETPT
- SET CNT=CNT+1
- SET PSOTEXT(CNT)=" "
- SET CNT=CNT+1
- SET PSOTEXT(CNT)=PSOTXT
- +12 SET PSOSQ=""
- FOR
- SET PSOSQ=$ORDER(^TMP($JOB,"PSOPOS11",NAM,DFN,PSOSQ))
- if PSOSQ=""
- QUIT
- Begin DoDot:3
- +13 IF PSOSQ="P"
- SET PSORX=""
- FOR
- SET PSORX=$ORDER(^TMP($JOB,"PSOPOS11",NAM,DFN,PSOSQ,PSORX))
- if PSORX=""
- QUIT
- SET CNT=CNT+1
- SET PSOTEXT(CNT)=" ""P"" CROSS-REFERENCE REBUILT FOR RX#: "_PSORX
- +14 IF PSOSQ="P,A"
- SET PSORX=""
- FOR
- SET PSORX=$ORDER(^TMP($JOB,"PSOPOS11",NAM,DFN,PSOSQ,PSORX))
- if PSORX=""
- QUIT
- SET CNT=CNT+1
- SET PSOTEXT(CNT)=" ""P"",""A"" CROSS-REFERENCE REBUILT FOR RX#: "_PSORX
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +15 IF CNT=4
- SET CNT=CNT+1
- SET PSOTEXT(CNT)="No missing Cross References"
- +16 SET CNT=CNT+1
- SET PSOTEXT(CNT)=" "
- SET PSOTEXT(CNT+1)="** END OF LIST **"
- +17 SET XMTEXT="PSOTEXT("
- NEW DIFROM
- DO ^XMD
- +18 KILL PSOTIMEA,PSOTIMEB,XMDUZ,XMSUB,PSOTEXT,XMTEXT,PSODT2,^TMP($JOB,"PSOPOS11"),CNT,DFN,MSG,NAM,PSODT,PSOJOB,PSOSQ,PSOSQ1,PSOTXT
- +19 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +20 QUIT
- +21 ;
- 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("PSOPOS10",$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("PSOPOS10",$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))
- Begin DoDot:1
- +2 ;S ^PS(55,PSODFN,0)=PSODFN_"^^^^^2"
- +3 LOCK +^PS(55,PSODFN)
- +4 SET PSOUPD=2
- +5 KILL DIC
- SET DIC="^PS(55,"
- SET DIC(0)="L"
- SET (X,DINUM)=PSODFN
- SET DIC("DR")="52.1///"_PSOUPD
- +6 KILL DD,DO
- DO FILE^DICN
- KILL DD,DO,DIE,X,DINUM
- +7 LOCK -^PS(55,PSODFN)
- End DoDot:1
- +8 QUIT
- +9 ;
- 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("PSOPOS10",$JOB,PSODFN))
- if 'PSODFN
- QUIT
- SET PSOCTP=PSOCTP+1
- Begin DoDot:1
- +3 KILL ^TMP("PSOPOS10",$JOB)
- +4 SET CNT=0
- +5 ; quit if only "P,A" entries
- IF '$ORDER(^XTMP("PSOPOS10",$JOB,PSODFN,""))
- QUIT
- +6 LOCK +^PS(55,PSODFN)
- +7 SET PSODT=""
- FOR
- SET PSODT=$ORDER(^XTMP("PSOPOS10",$JOB,PSODFN,PSODT))
- if 'PSODT
- QUIT
- SET RXP=""
- FOR
- SET RXP=$ORDER(^XTMP("PSOPOS10",$JOB,PSODFN,PSODT,RXP))
- if 'RXP
- QUIT
- Begin DoDot:2
- +8 SET PSOIDT=$PIECE($GET(^PSRX(RXP,0)),"^",13)
- IF PSOIDT'=""
- IF '$DATA(^TMP("PSOPOS10",$JOB,PSOIDT,RXP))
- SET ^TMP("PSOPOS10",$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("PSOPOS10",$JOB,PSOIDT,RXP))
- SET ^TMP("PSOPOS10",$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("PSOPOS10",$JOB,PSOIDT))
- if 'PSOIDT
- QUIT
- SET RXP=""
- FOR
- SET RXP=$ORDER(^TMP("PSOPOS10",$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("PSOPOS10",$JOB)
- +18 QUIT
- +19 ;
- GETLIST ; PROCESS ENTRIES FROM ^XTMP("PSOPOS10" GLOBAL
- +1 KILL ^TMP($JOB,"PSOPOS11")
- +2 SET PSOJOB=""
- FOR
- SET PSOJOB=$ORDER(^XTMP("PSOPOS10",PSOJOB))
- if PSOJOB=""
- QUIT
- Begin DoDot:1
- +3 SET PSOSQ=""
- FOR
- SET PSOSQ=$ORDER(^XTMP("PSOPOS10",PSOJOB,PSOSQ))
- if PSOSQ=""
- QUIT
- Begin DoDot:2
- +4 SET NAM=$PIECE($GET(^DPT(PSOSQ,0)),"^",1)
- IF NAM=""
- SET NAM="UNKNOWN"
- +5 SET PSOSQ1=""
- FOR
- SET PSOSQ1=$ORDER(^XTMP("PSOPOS10",PSOJOB,PSOSQ,PSOSQ1))
- if PSOSQ1=""
- QUIT
- Begin DoDot:3
- +6 IF PSOSQ1="P,A"
- DO GETPA
- QUIT
- +7 SET PSORX=""
- FOR
- SET PSORX=$ORDER(^XTMP("PSOPOS10",PSOJOB,PSOSQ,PSOSQ1,PSORX))
- if PSORX=""
- QUIT
- SET PSORXP=$PIECE($GET(^PSRX(PSORX,0)),"^",1)
- IF PSORXP'=""
- SET ^TMP($JOB,"PSOPOS11",NAM,PSOSQ,"P",PSORXP)=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +8 QUIT
- +9 ;
- GETPT ; GET PATIENT INFORMATION
- +1 DO PID^VADPT
- +2 SET PSOTXT=$PIECE($GET(^DPT(DFN,0)),"^",1)_" ("_$GET(VA("BID"))_")"
- +3 QUIT
- +4 ;
- GETPA ;
- +1 SET PSODT=""
- FOR
- SET PSODT=$ORDER(^XTMP("PSOPOS10",PSOJOB,PSOSQ,PSOSQ1,PSODT))
- if PSODT=""
- QUIT
- Begin DoDot:1
- +2 SET PSORX=""
- FOR
- SET PSORX=$ORDER(^XTMP("PSOPOS10",PSOJOB,PSOSQ,PSOSQ1,PSODT,PSORX))
- if PSORX=""
- QUIT
- SET PSORXP=$PIECE($GET(^PSRX(PSORX,0)),"^",1)
- IF PSORXP'=""
- SET ^TMP($JOB,"PSOPOS11",NAM,PSOSQ,"P,A",PSORXP)=""
- End DoDot:1
- +3 QUIT
- +4 ;