PSUOP2 ;BIR/CFL - PSU PBM Outpatient Pharmacy Data Collection for Version 7.0 ; 7/11/06 4:21pm
;;4.0;PHARMACY BENEFITS MANAGEMENT;**6,8,9**;MARCH, 2005;Build 6
;
;DBIAs
; Reference to ^PSRX( file # 52 supported by DBIAs 465, 2512
; Reference to EN^PSOORDER supported by DBIA 1878
;
;
EN ;Entry to data collection
D ALLOOP,AMLOOP
K ^TMP("PSOR",$J)
Q
ALLOOP ;Loop through the AL cross refererence
N PSUDOC1,PSUCAN,PSUCL,PSUCMP,PSUFP,PSUORDT,PSUCO
S PSUFDT=PSUSDT,PSUEDTM=PSUEDT_".24"
F S PSUFDT=$O(^PSRX("AL",PSUFDT)) Q:PSUFDT=""!(PSUFDT>PSUEDTM) D
.S PSURXIEN=""
.F S PSURXIEN=$O(^PSRX("AL",PSUFDT,PSURXIEN)) Q:PSURXIEN="" D
..Q:$D(^XTMP(PSUOPSUB,"RXIEN",PSURXIEN)) ; already been processed
..Q:'$D(^PSRX(PSURXIEN,0)) ; watch out for dangling pointers
..S PSUCAN=$$GET1^DIQ(52,PSURXIEN,26.1,"I") ;Cancel date
..D GETS^PSUTL(52,PSURXIEN,"2;21;27","PSUOP","I")
..D MOVEI^PSUTL("PSUOP")
..S DFN=PSUOP(2)
..;
..Q:$$TESTPAT^PSUTL1(DFN)
..D PID^VADPT
..S PSUSSN=$TR(VA("PID"),"^-","")
..N PSUPSO S PSUPSO=1 ;flag to avoid a PSO error when SIG is too long
..D EN^PSOORDER(DFN,PSURXIEN)
..Q:'$D(^TMP("PSOR",$J))
..D EN^PSUOPAM ;Gather AMIS data
..D CMOPA ; set array of CMOP recs
..D NEW ; check ^TMP to see if New Rx is in time frame, if so create record.
..D REF ; check ^TMP to see if refills are in time frame, if so create records
..D PAR ; check ^TMP to see if partials are in time frame, if so create records
Q
;
AMLOOP ; loop through "AM", partials, cross reference to see if any were missed
S X1=PSUSDT,X2=-1
D C^%DTC K %,%H,%T
S PSUFDT=PSUSDT,PSUEDTM=PSUEDT_".24"
F S PSUFDT=$O(^PSRX("AM",PSUFDT)) Q:PSUFDT=""!(PSUFDT>PSUEDTM) D
.S PSURXIEN=""
.F S PSURXIEN=$O(^PSRX("AM",PSUFDT,PSURXIEN)) Q:PSURXIEN="" D
..Q:$D(^XTMP(PSUOPSUB,"RXIEN",PSURXIEN)) ; already been processed
..Q:'$D(^PSRX(PSURXIEN,0)) ; watch out for dangling pointers
..D GETS^PSUTL(52,PSURXIEN,"2;27","PSUOP","I")
..D MOVEI^PSUTL("PSUOP")
..S DFN=PSUOP(2)
..; SCREEN OUT TEST PATIENTS
..Q:$$TESTPAT^PSUTL1(DFN)
..D PID^VADPT
..S PSUSSN=$TR(VA("PID"),"^-","")
..D EN^PSOORDER(DFN,PSURXIEN)
..D EN^PSUOPAM ;Gather AMIS data PSU*4*5 fix
..D PAR ; check ^TMP to see if partials are in time frame, if so create records
Q
;
NEW ; New Rx
S PSUFD=$P(^TMP("PSOR",$J,PSURXIEN,0),U,2)
D COMVAR
S PSUTYP="N"
S PSUCMOP=$S($D(PSUCMA(0)):"Y",1:"N")
S PSUR0=^TMP("PSOR",$J,PSURXIEN,0)
S PSUORDT=$P(PSUR0,U,17) ;AMIS Original Login Date
S PSUQTY=+$P(PSUR0,U,6)
;
;
S PSUDS=$P(PSUR0,U,7)
S PSUDRCT=$P(PSUR0,U,10)
S PSURELDT=$P($P(PSUR0,U,13),".",1)
Q:((PSURELDT<PSUSDT)!(PSURELDT>PSUEDTM))
S PSUWPC=$E($P(PSUR0,U,15))
NEWX1 ;I PSUCMOP="Y" Q:((PSURELDT="")!(PSURELDT<PSUSDT)!(PSURELDT>PSUEDTM))
NEWX2 ;I PSUCMOP="N",((PSUFD<PSUSDT)!(PSUFD\1>PSUEDT)) Q
S PSUR1=^TMP("PSOR",$J,PSURXIEN,1)
; MOVE NEXT 2 LINES TO COMMON VARIABLE AREA
;S PSUCLN=$P($P(PSUR1,U,4),";",2) ;AMIS data clinic
;S PSUFP=$P($P(PSUR1,U,9),";",1) ;AMIS finishing person
S PSUPRID=$P($P(PSUR1,U,1),";",1)
S PSURXP=$P($P(PSUR1,U,5),";",1)
S PSUMW=$P($P(PSUR1,U,6),";",1)
S PSUDIVP=$P(PSUR1,U,7)
;
S PSUNDC=""
I PSUCMOP="Y" S PSUNDC=PSUCMA(0)
I PSUNDC="" S PSUNDC=$S($L(PSUOP(27)):PSUOP(27),$L(PSUDRUG(31)):PSUDRUG(31),1:"No NDC")
D PROVDR^PSUOP3
D SETREC^PSUOP3
NEWQ Q
;
REF ; Refills
Q:'$D(^TMP("PSOR",$J,PSURXIEN,"REF"))
D COMVAR
S PSUFLN=""
F S PSUFLN=$O(^TMP("PSOR",$J,PSURXIEN,"REF",PSUFLN)) Q:PSUFLN="" D
.S PSUTYP="R"
.S PSUCMOP=$S($D(PSUCMA(PSUFLN)):"Y",1:"N")
.S PSUR0=^TMP("PSOR",$J,PSURXIEN,"REF",PSUFLN,0)
.N PSUCLN,PSUR1
.S PSUR1=^TMP("PSOR",$J,PSURXIEN,1)
.S PSUCLN=$P($P(PSUR1,U,4),";",2)
.S PSUWPC="N"
.S PSUFD=$P(PSUR0,U,1)
.S PSUPRID=$P($P(PSUR0,U,2),";",1)
.S PSUQTY=+$P(PSUR0,U,4)
.S PSUDS=$P(PSUR0,U,5)
.S PSUDRCT=$P(PSUR0,U,6)
.S PSURELDT=$P(PSUR0,U,8)
.Q:((PSURELDT<PSUSDT)!(PSURELDT>PSUEDTM))
.S PSUMW=$P($P(PSUR0,U,10),";",1)
.S PSUDIVP=$P(PSUR0,U,11)
.S PSUREDT=$P(PSUR0,U,12) ;AMIS Refill Login Date
.I PSURELDT'="" S PSURELDT=PSURELDT\1
.;I PSUCMOP="Y" Q:((PSURELDT="")!(PSURELDT<PSUSDT)!(PSURELDT>PSUEDTM))
.;I PSUCMOP="N",((PSUFD<PSUSDT)!(PSUFD\1>PSUEDT)) Q
.S PSUNDC=""
.I PSUCMOP="Y" S PSUNDC=PSUCMA(PSUFLN)
.I PSUNDC="" S PSUNDC=$$VALI^PSUTL(52.1,PSURXIEN,11)
.I PSUNDC="" S PSUNDC=$S(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")
.;
.D PROVDR^PSUOP3
.D SETREC^PSUOP3
REFQ Q
;
PAR ; Partials
Q:'$D(^TMP("PSOR",$J,PSURXIEN,"RPAR"))
D COMVAR
S PSUFLN=""
F S PSUFLN=$O(^TMP("PSOR",$J,PSURXIEN,"RPAR",PSUFLN)) Q:PSUFLN="" D
.S PSUR0=^TMP("PSOR",$J,PSURXIEN,"RPAR",PSUFLN,0)
.N PSUCLN,PSUR1
.S PSUR1=^TMP("PSOR",$J,PSURXIEN,1)
.S PSUCLN=$P($P(PSUR1,U,4),";",2)
.S PSUTYP="P"
.S PSUCMOP="N"
.S PSUWPC="N"
.S PSUFD=$P(PSUR0,U,1)
.;I (PSUFD<PSUSDT)!(PSUFD\1>PSUEDT) Q
.S PSUPRID=$P($P(PSUR0,U,2),";",1)
.S PSUQTY=+$P(PSUR0,U,4)
.S PSUDS=$P(PSUR0,U,5)
.S PSUDRCT=$P(PSUR0,U,6)
.S PSURELDT=$P(PSUR0,U,8)
.S PSUMW=$P($P(PSUR0,U,10),";",1)
.S PSUDIVP=$P(PSUR0,U,11)
.S PSUPDT=$P(PSUR0,U,12) ;AMIS Partial Login Date
.I PSURELDT'="" S PSURELDT=PSURELDT\1
.Q:((PSURELDT<PSUSDT)!(PSURELDT>PSUEDTM))
.S PSUNDC=$$VALI^PSUTL(52.2,PSURXIEN,1)
.I PSUNDC="" S PSUNDC=$S(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")
.;
.D PROVDR^PSUOP3
.D SETREC^PSUOP3
PARQ Q
;
COMVAR ; set variables that are common between all record types
S PSUDR=$P($P(^TMP("PSOR",$J,PSURXIEN,"DRUG",0),U,1),";",1)
;S CMOPID=$P($G(^PSDRUG(PSUDR,"ND")),U,10) ;AMIS CMOP ID
S PSUSIG=$P($G(^TMP("PSOR",$J,PSURXIEN,"SIG",1,0)),U,1)
S PSURXP=$P($P(^TMP("PSOR",$J,PSURXIEN,1),U,5),";",1)
S PSURXN=$P(^TMP("PSOR",$J,PSURXIEN,0),U,5)
; PSU*4*9 - INSERT NEXT 2 LINES
S PSUCLN=$P($P(^TMP("PSOR",$J,PSURXIEN,1),U,4),";",2) ;AMIS CLINIC
S PSUFP=$P($P(^TMP("PSOR",$J,PSURXIEN,1),U,9),";",1) ;FINISHING PERSON
D GETDRUG^PSUOP3 ; loads data from file #50 using PSUDR as ien
COMVARQ Q
;
CMOPA ; set array of CMOP recs
K PSUCMA
N PSUR1,PSUX,PSUST,PSUFIL,PSUNDC
S PSUX=""
F S PSUX=$O(^TMP("PSOR",$J,PSURXIEN,"CMOP",PSUX)) Q:PSUX="" D
.S PSUR1=^TMP("PSOR",$J,PSURXIEN,"CMOP",PSUX,0)
.F X="PSUFIL^3","PSUST^4","PSUNDC^6" D PIECE(X,PSUR1,U)
.S:+PSUST=1 PSUCMA(PSUFIL)=PSUNDC
.K:+PSUST=3 PSUCMA(PSUFIL)
.D:$D(PSUCMA(PSUFIL)) RTSTOCK
CMOPAQ Q
;
RTSTOCK ; test for "AR" if none then unmark CMOP
; needs PSURXIEN, PSUFIL, from CMOPA
N PSURELDT,PSUR0,PSURTSDT
I PSUFIL D Q
. S PSUR0=$G(^TMP("PSOR",$J,PSURXIEN,"REF",PSUFIL,0))
. F X="PSURELDT^8","PSURTSDT^9" D PIECE(X,PSUR0,U)
. I PSURELDT,$D(^PSRX("AR",PSURELDT,PSURXIEN,PSUFIL)) Q
. K PSUCMA(PSUFIL)
;
S PSUR0=^TMP("PSOR",$J,PSURXIEN,0)
F X="PSURELDT^13","PSURTSDT^14" D PIECE(X,PSUR0,U)
I PSURELDT,$D(^PSRX("AR",PSURELDT,PSURXIEN,PSUFIL)) Q
I $D(PSUCMA(PSUFIL)) K PSUCMA(PSUFIL)
Q
PIECE(%,REC,DLM) ;Piece % from record REC using delimiter DLM
; %="VARNAME^PIECE",REC=SOURCE,DLM=DELIMITER in REC
N Y,I S Y=$P(%,U,1),I=$P(%,U,2) S @Y=$P(REC,DLM,I)
Q
;
PSUOP2 ;BIR/CFL - PSU PBM Outpatient Pharmacy Data Collection for Version 7.0 ; 7/11/06 4:21pm
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**6,8,9**;MARCH, 2005;Build 6
+2 ;
+3 ;DBIAs
+4 ; Reference to ^PSRX( file # 52 supported by DBIAs 465, 2512
+5 ; Reference to EN^PSOORDER supported by DBIA 1878
+6 ;
+7 ;
EN ;Entry to data collection
+1 DO ALLOOP
DO AMLOOP
+2 KILL ^TMP("PSOR",$JOB)
+3 QUIT
ALLOOP ;Loop through the AL cross refererence
+1 NEW PSUDOC1,PSUCAN,PSUCL,PSUCMP,PSUFP,PSUORDT,PSUCO
+2 SET PSUFDT=PSUSDT
SET PSUEDTM=PSUEDT_".24"
+3 FOR
SET PSUFDT=$ORDER(^PSRX("AL",PSUFDT))
IF PSUFDT=""!(PSUFDT>PSUEDTM)
QUIT
Begin DoDot:1
+4 SET PSURXIEN=""
+5 FOR
SET PSURXIEN=$ORDER(^PSRX("AL",PSUFDT,PSURXIEN))
IF PSURXIEN=""
QUIT
Begin DoDot:2
+6 ; already been processed
IF $DATA(^XTMP(PSUOPSUB,"RXIEN",PSURXIEN))
QUIT
+7 ; watch out for dangling pointers
IF '$DATA(^PSRX(PSURXIEN,0))
QUIT
+8 ;Cancel date
SET PSUCAN=$$GET1^DIQ(52,PSURXIEN,26.1,"I")
+9 DO GETS^PSUTL(52,PSURXIEN,"2;21;27","PSUOP","I")
+10 DO MOVEI^PSUTL("PSUOP")
+11 SET DFN=PSUOP(2)
+12 ;
+13 IF $$TESTPAT^PSUTL1(DFN)
QUIT
+14 DO PID^VADPT
+15 SET PSUSSN=$TRANSLATE(VA("PID"),"^-","")
+16 ;flag to avoid a PSO error when SIG is too long
NEW PSUPSO
SET PSUPSO=1
+17 DO EN^PSOORDER(DFN,PSURXIEN)
+18 IF '$DATA(^TMP("PSOR",$JOB))
QUIT
+19 ;Gather AMIS data
DO EN^PSUOPAM
+20 ; set array of CMOP recs
DO CMOPA
+21 ; check ^TMP to see if New Rx is in time frame, if so create record.
DO NEW
+22 ; check ^TMP to see if refills are in time frame, if so create records
DO REF
+23 ; check ^TMP to see if partials are in time frame, if so create records
DO PAR
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
AMLOOP ; loop through "AM", partials, cross reference to see if any were missed
+1 SET X1=PSUSDT
SET X2=-1
+2 DO C^%DTC
KILL %,%H,%T
+3 SET PSUFDT=PSUSDT
SET PSUEDTM=PSUEDT_".24"
+4 FOR
SET PSUFDT=$ORDER(^PSRX("AM",PSUFDT))
IF PSUFDT=""!(PSUFDT>PSUEDTM)
QUIT
Begin DoDot:1
+5 SET PSURXIEN=""
+6 FOR
SET PSURXIEN=$ORDER(^PSRX("AM",PSUFDT,PSURXIEN))
IF PSURXIEN=""
QUIT
Begin DoDot:2
+7 ; already been processed
IF $DATA(^XTMP(PSUOPSUB,"RXIEN",PSURXIEN))
QUIT
+8 ; watch out for dangling pointers
IF '$DATA(^PSRX(PSURXIEN,0))
QUIT
+9 DO GETS^PSUTL(52,PSURXIEN,"2;27","PSUOP","I")
+10 DO MOVEI^PSUTL("PSUOP")
+11 SET DFN=PSUOP(2)
+12 ; SCREEN OUT TEST PATIENTS
+13 IF $$TESTPAT^PSUTL1(DFN)
QUIT
+14 DO PID^VADPT
+15 SET PSUSSN=$TRANSLATE(VA("PID"),"^-","")
+16 DO EN^PSOORDER(DFN,PSURXIEN)
+17 ;Gather AMIS data PSU*4*5 fix
DO EN^PSUOPAM
+18 ; check ^TMP to see if partials are in time frame, if so create records
DO PAR
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
NEW ; New Rx
+1 SET PSUFD=$PIECE(^TMP("PSOR",$JOB,PSURXIEN,0),U,2)
+2 DO COMVAR
+3 SET PSUTYP="N"
+4 SET PSUCMOP=$SELECT($DATA(PSUCMA(0)):"Y",1:"N")
+5 SET PSUR0=^TMP("PSOR",$JOB,PSURXIEN,0)
+6 ;AMIS Original Login Date
SET PSUORDT=$PIECE(PSUR0,U,17)
+7 SET PSUQTY=+$PIECE(PSUR0,U,6)
+8 ;
+9 ;
+10 SET PSUDS=$PIECE(PSUR0,U,7)
+11 SET PSUDRCT=$PIECE(PSUR0,U,10)
+12 SET PSURELDT=$PIECE">PIECE($PIECE">PIECE(PSUR0,U,13),".",1)
+13 IF ((PSURELDT<PSUSDT)!(PSURELDT>PSUEDTM))
QUIT
+14 SET PSUWPC=$EXTRACT($PIECE(PSUR0,U,15))
NEWX1 ;I PSUCMOP="Y" Q:((PSURELDT="")!(PSURELDT<PSUSDT)!(PSURELDT>PSUEDTM))
NEWX2 ;I PSUCMOP="N",((PSUFD<PSUSDT)!(PSUFD\1>PSUEDT)) Q
+1 SET PSUR1=^TMP("PSOR",$JOB,PSURXIEN,1)
+2 ; MOVE NEXT 2 LINES TO COMMON VARIABLE AREA
+3 ;S PSUCLN=$P($P(PSUR1,U,4),";",2) ;AMIS data clinic
+4 ;S PSUFP=$P($P(PSUR1,U,9),";",1) ;AMIS finishing person
+5 SET PSUPRID=$PIECE">PIECE($PIECE">PIECE(PSUR1,U,1),";",1)
+6 SET PSURXP=$PIECE">PIECE($PIECE">PIECE(PSUR1,U,5),";",1)
+7 SET PSUMW=$PIECE">PIECE($PIECE">PIECE(PSUR1,U,6),";",1)
+8 SET PSUDIVP=$PIECE(PSUR1,U,7)
+9 ;
+10 SET PSUNDC=""
+11 IF PSUCMOP="Y"
SET PSUNDC=PSUCMA(0)
+12 IF PSUNDC=""
SET PSUNDC=$SELECT($LENGTH(PSUOP(27)):PSUOP(27),$LENGTH(PSUDRUG(31)):PSUDRUG(31),1:"No NDC")
+13 DO PROVDR^PSUOP3
+14 DO SETREC^PSUOP3
NEWQ QUIT
+1 ;
REF ; Refills
+1 IF '$DATA(^TMP("PSOR",$JOB,PSURXIEN,"REF"))
QUIT
+2 DO COMVAR
+3 SET PSUFLN=""
+4 FOR
SET PSUFLN=$ORDER(^TMP("PSOR",$JOB,PSURXIEN,"REF",PSUFLN))
IF PSUFLN=""
QUIT
Begin DoDot:1
+5 SET PSUTYP="R"
+6 SET PSUCMOP=$SELECT($DATA(PSUCMA(PSUFLN)):"Y",1:"N")
+7 SET PSUR0=^TMP("PSOR",$JOB,PSURXIEN,"REF",PSUFLN,0)
+8 NEW PSUCLN,PSUR1
+9 SET PSUR1=^TMP("PSOR",$JOB,PSURXIEN,1)
+10 SET PSUCLN=$PIECE">PIECE($PIECE">PIECE(PSUR1,U,4),";",2)
+11 SET PSUWPC="N"
+12 SET PSUFD=$PIECE(PSUR0,U,1)
+13 SET PSUPRID=$PIECE">PIECE($PIECE">PIECE(PSUR0,U,2),";",1)
+14 SET PSUQTY=+$PIECE(PSUR0,U,4)
+15 SET PSUDS=$PIECE(PSUR0,U,5)
+16 SET PSUDRCT=$PIECE(PSUR0,U,6)
+17 SET PSURELDT=$PIECE(PSUR0,U,8)
+18 IF ((PSURELDT<PSUSDT)!(PSURELDT>PSUEDTM))
QUIT
+19 SET PSUMW=$PIECE">PIECE($PIECE">PIECE(PSUR0,U,10),";",1)
+20 SET PSUDIVP=$PIECE(PSUR0,U,11)
+21 ;AMIS Refill Login Date
SET PSUREDT=$PIECE(PSUR0,U,12)
+22 IF PSURELDT'=""
SET PSURELDT=PSURELDT\1
+23 ;I PSUCMOP="Y" Q:((PSURELDT="")!(PSURELDT<PSUSDT)!(PSURELDT>PSUEDTM))
+24 ;I PSUCMOP="N",((PSUFD<PSUSDT)!(PSUFD\1>PSUEDT)) Q
+25 SET PSUNDC=""
+26 IF PSUCMOP="Y"
SET PSUNDC=PSUCMA(PSUFLN)
+27 IF PSUNDC=""
SET PSUNDC=$$VALI^PSUTL(52.1,PSURXIEN,11)
+28 IF PSUNDC=""
SET PSUNDC=$SELECT(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")
+29 ;
+30 DO PROVDR^PSUOP3
+31 DO SETREC^PSUOP3
End DoDot:1
REFQ QUIT
+1 ;
PAR ; Partials
+1 IF '$DATA(^TMP("PSOR",$JOB,PSURXIEN,"RPAR"))
QUIT
+2 DO COMVAR
+3 SET PSUFLN=""
+4 FOR
SET PSUFLN=$ORDER(^TMP("PSOR",$JOB,PSURXIEN,"RPAR",PSUFLN))
IF PSUFLN=""
QUIT
Begin DoDot:1
+5 SET PSUR0=^TMP("PSOR",$JOB,PSURXIEN,"RPAR",PSUFLN,0)
+6 NEW PSUCLN,PSUR1
+7 SET PSUR1=^TMP("PSOR",$JOB,PSURXIEN,1)
+8 SET PSUCLN=$PIECE">PIECE($PIECE">PIECE(PSUR1,U,4),";",2)
+9 SET PSUTYP="P"
+10 SET PSUCMOP="N"
+11 SET PSUWPC="N"
+12 SET PSUFD=$PIECE(PSUR0,U,1)
+13 ;I (PSUFD<PSUSDT)!(PSUFD\1>PSUEDT) Q
+14 SET PSUPRID=$PIECE">PIECE($PIECE">PIECE(PSUR0,U,2),";",1)
+15 SET PSUQTY=+$PIECE(PSUR0,U,4)
+16 SET PSUDS=$PIECE(PSUR0,U,5)
+17 SET PSUDRCT=$PIECE(PSUR0,U,6)
+18 SET PSURELDT=$PIECE(PSUR0,U,8)
+19 SET PSUMW=$PIECE">PIECE($PIECE">PIECE(PSUR0,U,10),";",1)
+20 SET PSUDIVP=$PIECE(PSUR0,U,11)
+21 ;AMIS Partial Login Date
SET PSUPDT=$PIECE(PSUR0,U,12)
+22 IF PSURELDT'=""
SET PSURELDT=PSURELDT\1
+23 IF ((PSURELDT<PSUSDT)!(PSURELDT>PSUEDTM))
QUIT
+24 SET PSUNDC=$$VALI^PSUTL(52.2,PSURXIEN,1)
+25 IF PSUNDC=""
SET PSUNDC=$SELECT(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")
+26 ;
+27 DO PROVDR^PSUOP3
+28 DO SETREC^PSUOP3
End DoDot:1
PARQ QUIT
+1 ;
COMVAR ; set variables that are common between all record types
+1 SET PSUDR=$PIECE">PIECE($PIECE">PIECE(^TMP("PSOR",$JOB,PSURXIEN,"DRUG",0),U,1),";",1)
+2 ;S CMOPID=$P($G(^PSDRUG(PSUDR,"ND")),U,10) ;AMIS CMOP ID
+3 SET PSUSIG=$PIECE($GET(^TMP("PSOR",$JOB,PSURXIEN,"SIG",1,0)),U,1)
+4 SET PSURXP=$PIECE">PIECE($PIECE">PIECE(^TMP("PSOR",$JOB,PSURXIEN,1),U,5),";",1)
+5 SET PSURXN=$PIECE(^TMP("PSOR",$JOB,PSURXIEN,0),U,5)
+6 ; PSU*4*9 - INSERT NEXT 2 LINES
+7 ;AMIS CLINIC
SET PSUCLN=$PIECE">PIECE($PIECE">PIECE(^TMP("PSOR",$JOB,PSURXIEN,1),U,4),";",2)
+8 ;FINISHING PERSON
SET PSUFP=$PIECE">PIECE($PIECE">PIECE(^TMP("PSOR",$JOB,PSURXIEN,1),U,9),";",1)
+9 ; loads data from file #50 using PSUDR as ien
DO GETDRUG^PSUOP3
COMVARQ QUIT
+1 ;
CMOPA ; set array of CMOP recs
+1 KILL PSUCMA
+2 NEW PSUR1,PSUX,PSUST,PSUFIL,PSUNDC
+3 SET PSUX=""
+4 FOR
SET PSUX=$ORDER(^TMP("PSOR",$JOB,PSURXIEN,"CMOP",PSUX))
IF PSUX=""
QUIT
Begin DoDot:1
+5 SET PSUR1=^TMP("PSOR",$JOB,PSURXIEN,"CMOP",PSUX,0)
+6 FOR X="PSUFIL^3","PSUST^4","PSUNDC^6"
DO PIECE(X,PSUR1,U)
+7 IF +PSUST=1
SET PSUCMA(PSUFIL)=PSUNDC
+8 IF +PSUST=3
KILL PSUCMA(PSUFIL)
+9 IF $DATA(PSUCMA(PSUFIL))
DO RTSTOCK
End DoDot:1
CMOPAQ QUIT
+1 ;
RTSTOCK ; test for "AR" if none then unmark CMOP
+1 ; needs PSURXIEN, PSUFIL, from CMOPA
+2 NEW PSURELDT,PSUR0,PSURTSDT
+3 IF PSUFIL
Begin DoDot:1
+4 SET PSUR0=$GET(^TMP("PSOR",$JOB,PSURXIEN,"REF",PSUFIL,0))
+5 FOR X="PSURELDT^8","PSURTSDT^9"
DO PIECE(X,PSUR0,U)
+6 IF PSURELDT
IF $DATA(^PSRX("AR",PSURELDT,PSURXIEN,PSUFIL))
QUIT
+7 KILL PSUCMA(PSUFIL)
End DoDot:1
QUIT
+8 ;
+9 SET PSUR0=^TMP("PSOR",$JOB,PSURXIEN,0)
+10 FOR X="PSURELDT^13","PSURTSDT^14"
DO PIECE(X,PSUR0,U)
+11 IF PSURELDT
IF $DATA(^PSRX("AR",PSURELDT,PSURXIEN,PSUFIL))
QUIT
+12 IF $DATA(PSUCMA(PSUFIL))
KILL PSUCMA(PSUFIL)
+13 QUIT
PIECE(%,REC,DLM) ;Piece % from record REC using delimiter DLM
+1 ; %="VARNAME^PIECE",REC=SOURCE,DLM=DELIMITER in REC
+2 NEW Y,I
SET Y=$PIECE(%,U,1)
SET I=$PIECE(%,U,2)
SET @Y=$PIECE(REC,DLM,I)
+3 QUIT
+4 ;
