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 Dec 13, 2024@02:32:48 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 ;
