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