PSO581PO ;ALB/BWF^PSO*7*581 POST INIT ; 10/25/2019 11:14am
;;7.0;OUTPATIENT PHARMACY;**581**;DEC 1997;Build 126
D CONV5245,NCIT,ERXPOP,REFREN
S DIK="^PS(52.45,",DIK(1)="2.1^E" D ENALL^DIK K DIK
K ^TMP("PSO581PO")
Q
;;INCOMING COLUMNS
;; 1 - NCIt Subset Code
;; 2 - NCPDP Subset Preferred Term
;; 3 - NCIt code
;; 4 - NCPDP Preferred Term
;; 5 - NCPDP Synonym (this is blank for all records except 1)
;; 6 - NCIt Preferred Term
;; 7 - NCI Definition
NCIT ;
N DONE,LINE,I,CODTYPE,X,NCICODE,BDESC,FDESC,NIEN,REC,DATA,FDARY,REC,G,FDA,ERR,Y,SUBT
S DONE=0
S CODTYPE="NCI"
K ^TMP($J,"WP")
S X=0 F S X=$O(^TMP("PSO581PO","NCI",X)) Q:'X D
.S DATA=$G(^TMP("PSO581PO","NCI",X,0))
.S NCICODE=$P(DATA,$C(9),3)
.S BDESC=$P(DATA,$C(9),6),BDESC=$$UP^XLFSTR(BDESC)
.S FDESC=$P(DATA,$C(9),7)
.S SUBT=$P($P(DATA,$C(9),2)," ",2)
.; if this code already exists, update it and quit.
.I $D(^PS(52.45,"C","NCI",NCICODE)) D Q
..S EIEN=$O(^PS(52.45,"C","NCI",NCICODE,0)) Q:'EIEN
..S FDA(52.45,EIEN_",",.01)=NCICODE
..S FDA(52.45,EIEN_",",.02)=BDESC
..S FDA(52.45,EIEN_",",.03)=CODTYPE
..S FDA(52.45,EIEN_",",.04)="NCIt"
..S FDA(52.45,EIEN_",",2.1)=SUBT
..D FILE^DIE(,"FDA") K FDA
..D TXT2ARY^PSOERXD1(.FDARY,FDESC,,80)
..S Y=0 F S Y=$O(FDARY(Y)) Q:'Y D
...S ^TMP($J,"WP",Y)=$G(FDARY(Y))
..D WP^DIE(52.45,EIEN_",",1,"K","^TMP($J,""WP"")")
..K EIEN,^TMP($J,"WP"),FDARY,FDESC
.S FDA(52.45,"+1,",.01)=NCICODE
.S FDA(52.45,"+1,",.02)=BDESC
.S FDA(52.45,"+1,",.03)=CODTYPE
.S FDA(52.45,"+1,",.04)="NCIt"
.S FDA(52.45,"+1,",2.1)=SUBT
.D UPDATE^DIE(,"FDA","NIEN") K FDA
.S REC=$O(NIEN(0)),NIEN=$G(NIEN(REC))
.D TXT2ARY^PSOERXD1(.FDARY,FDESC,,80)
.S Y=0 F S Y=$O(FDARY(Y)) Q:'Y D
..S ^TMP($J,"WP",Y)=$G(FDARY(Y))
.D WP^DIE(52.45,NIEN_",",1,"K","^TMP($J,""WP"")")
.K NIEN,^TMP($J,"WP"),FDARY,FDESC
Q
; convert 52.45, field .03 from a set of codes into two separate free text fields
CONV5245 ;
N IEN,A,CDESC,FDA
S IEN=0 F S IEN=$O(^PS(52.45,IEN)) Q:'IEN D
.S A=$$GET1^DIQ(52.45,IEN,.03,"E")
.S CDESC=$S(A="REA":"SERVICE REASON",A="RES":"SERVICE RESULT",A="PSC":"PROFESSIONAL SERVICE",A="ERX":"ERX STATUS",A="DCS":"DRUG COVERAGE",1:"")
.I CDESC="" S CDESC=$S(A="PAV":"PRIOR AUTHORIZATION",A="CAQ":"CO-AGENT QUALIFIER",A="REJ":"REJECT REASON",A="REM":"REMOVAL REASON",A="DDB":"DRUG DB QUALIFIER",A="CLQ":"CODE LIST QUALIFIER",A="ERR":"ERROR",1:"")
.S FDA(52.45,IEN_",",.04)=CDESC D FILE^DIE(,"FDA") K FDA
Q
ERXPOP ;
N I,DONE,NIEN,ELINE,ECODE,EDESC,ELONG,EIEN,TYPE,SUB,CTTEXT,FDA,Y,FDARY,NIEN
F TYPE="QCQ","PAY","CIQ","PCQ","CAQ","ACR","DDB","ICQ","PQC","ERX","MRC","MRSC","CLQ" D
.S SUB=TYPE
.I TYPE="QCQ" S CTTEXT="QUANTITY CODE LIST QUALIFIER"
.I TYPE="PAY" S CTTEXT="PAYER TYPE"
.I TYPE="CIQ" S CTTEXT="COMPOUND INGREDIENT PRODUCT CODE QUALIFIER"
.I TYPE="PCQ" S CTTEXT="PATIENT CODIFIED NOTE QUALIFIER"
.I TYPE="CAQ" S CTTEXT="CO-AGENT QUALIFIER"
.I TYPE="ACR" S CTTEXT="ALTERNATE CONTACT RELATIONSHIP"
.I TYPE="DDB" S CTTEXT="DRUG DB QUALIFIER"
.I TYPE="ICQ" S CTTEXT="INGREDIENT CODE QUALIFIER"
.I TYPE="PQC" S CTTEXT="PRODUCT QUALIFIER CODE"
.I TYPE="ERX" S CTTEXT="ERX STATUS"
.I TYPE="MRC" S CTTEXT="MESSAGE REQUEST CODE"
.I TYPE="MRSC" S CTTEXT="MESSAGE REQUEST SUB-CODE"
.I TYPE="CLQ" S CTTEXT="CODE LIST QUALIFIER"
.S DONE=0
.F I=1:1 D Q:DONE
..K NIEN
..S ELINE=$G(^TMP("PSO581PO",TYPE,I,0))
..I ELINE=" Q"!(ELINE="") S DONE=1 Q
..S ECODE=$P(ELINE,U),EDESC=$P(ELINE,U,2),ELONG=$P(ELINE,U,3)
..I $D(^PS(52.45,"C",SUB,ECODE)) D Q
...S EIEN=$O(^PS(52.45,"C",SUB,ECODE,0)) Q:'EIEN
...S FDA(52.45,EIEN_",",.01)=ECODE
...S FDA(52.45,EIEN_",",.02)=EDESC
...S FDA(52.45,EIEN_",",.03)=SUB
...S FDA(52.45,EIEN_",",.04)=CTTEXT
...D FILE^DIE(,"FDA") K FDA
...D TXT2ARY^PSOERXD1(.FDARY,ELONG,,80)
...S Y=0 F S Y=$O(FDARY(Y)) Q:'Y D
....S ^TMP($J,"WP",Y)=$G(FDARY(Y))
...D WP^DIE(52.45,EIEN_",",1,"K","^TMP($J,""WP"")")
...K NIEN,^TMP($J,"WP"),FDARY,ELONG
..S FDA(52.45,"+1,",.01)=ECODE
..S FDA(52.45,"+1,",.02)=EDESC
..S FDA(52.45,"+1,",.03)=SUB
..S FDA(52.45,"+1,",.04)=CTTEXT
..D UPDATE^DIE(,"FDA","NIEN") K FDA
..S REC=$O(NIEN(0)),NIEN=$G(NIEN(REC))
..D TXT2ARY^PSOERXD1(.FDARY,ELONG,,80)
..S Y=0 F S Y=$O(FDARY(Y)) Q:'Y D
...S ^TMP($J,"WP",Y)=$G(FDARY(Y))
..D WP^DIE(52.45,NIEN_",",1,"K","^TMP($J,""WP"")")
..K NIEN,^TMP($J,"WP"),FDARY,ELONG
Q
; change eRx status entries from 'refill' to 'rx renewal'
REFREN ;
N CODE,SIEN,STAT,FDA,NSTAT,P1,P2
S CODE="" F S CODE=$O(^PS(52.45,"C","ERX",CODE)) Q:CODE="" D
.S SIEN=0 F S SIEN=$O(^PS(52.45,"C","ERX",CODE,SIEN)) Q:'SIEN D
..I CODE="IRA" S FDA(52.45,SIEN_",",.02)="INBOUND RXRENEWAL ERROR ACKNOWLEDGED" D FILE^DIE(,"FDA") K FDA Q
..; only convert the refill/renewal status entries
..Q:$E(CODE)'="R"
..S STAT=$$GET1^DIQ(52.45,SIEN,.02,"E")
..Q:STAT'["REFILL"
..; the word 'refill' only occurs once per instance, so simply gathering 2 pieces is sufficient for this activity
..S P1=$P(STAT,"REFILL",1),P2=$P(STAT,"REFILL",2)
..S NSTAT=P1_"RXRENEWAL"_P2
..S FDA(52.45,SIEN_",",.02)=NSTAT D FILE^DIE(,"FDA") K FDA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO581PO 5181 printed Apr 09, 2024@21:29:30 Page 2
PSO581PO ;ALB/BWF^PSO*7*581 POST INIT ; 10/25/2019 11:14am
+1 ;;7.0;OUTPATIENT PHARMACY;**581**;DEC 1997;Build 126
+2 DO CONV5245
DO NCIT
DO ERXPOP
DO REFREN
+3 SET DIK="^PS(52.45,"
SET DIK(1)="2.1^E"
DO ENALL^DIK
KILL DIK
+4 KILL ^TMP("PSO581PO")
+5 QUIT
+6 ;;INCOMING COLUMNS
+7 ;; 1 - NCIt Subset Code
+8 ;; 2 - NCPDP Subset Preferred Term
+9 ;; 3 - NCIt code
+10 ;; 4 - NCPDP Preferred Term
+11 ;; 5 - NCPDP Synonym (this is blank for all records except 1)
+12 ;; 6 - NCIt Preferred Term
+13 ;; 7 - NCI Definition
NCIT ;
+1 NEW DONE,LINE,I,CODTYPE,X,NCICODE,BDESC,FDESC,NIEN,REC,DATA,FDARY,REC,G,FDA,ERR,Y,SUBT
+2 SET DONE=0
+3 SET CODTYPE="NCI"
+4 KILL ^TMP($JOB,"WP")
+5 SET X=0
FOR
SET X=$ORDER(^TMP("PSO581PO","NCI",X))
if 'X
QUIT
Begin DoDot:1
+6 SET DATA=$GET(^TMP("PSO581PO","NCI",X,0))
+7 SET NCICODE=$PIECE(DATA,$CHAR(9),3)
+8 SET BDESC=$PIECE(DATA,$CHAR(9),6)
SET BDESC=$$UP^XLFSTR(BDESC)
+9 SET FDESC=$PIECE(DATA,$CHAR(9),7)
+10 SET SUBT=$PIECE($PIECE(DATA,$CHAR(9),2)," ",2)
+11 ; if this code already exists, update it and quit.
+12 IF $DATA(^PS(52.45,"C","NCI",NCICODE))
Begin DoDot:2
+13 SET EIEN=$ORDER(^PS(52.45,"C","NCI",NCICODE,0))
if 'EIEN
QUIT
+14 SET FDA(52.45,EIEN_",",.01)=NCICODE
+15 SET FDA(52.45,EIEN_",",.02)=BDESC
+16 SET FDA(52.45,EIEN_",",.03)=CODTYPE
+17 SET FDA(52.45,EIEN_",",.04)="NCIt"
+18 SET FDA(52.45,EIEN_",",2.1)=SUBT
+19 DO FILE^DIE(,"FDA")
KILL FDA
+20 DO TXT2ARY^PSOERXD1(.FDARY,FDESC,,80)
+21 SET Y=0
FOR
SET Y=$ORDER(FDARY(Y))
if 'Y
QUIT
Begin DoDot:3
+22 SET ^TMP($JOB,"WP",Y)=$GET(FDARY(Y))
End DoDot:3
+23 DO WP^DIE(52.45,EIEN_",",1,"K","^TMP($J,""WP"")")
+24 KILL EIEN,^TMP($JOB,"WP"),FDARY,FDESC
End DoDot:2
QUIT
+25 SET FDA(52.45,"+1,",.01)=NCICODE
+26 SET FDA(52.45,"+1,",.02)=BDESC
+27 SET FDA(52.45,"+1,",.03)=CODTYPE
+28 SET FDA(52.45,"+1,",.04)="NCIt"
+29 SET FDA(52.45,"+1,",2.1)=SUBT
+30 DO UPDATE^DIE(,"FDA","NIEN")
KILL FDA
+31 SET REC=$ORDER(NIEN(0))
SET NIEN=$GET(NIEN(REC))
+32 DO TXT2ARY^PSOERXD1(.FDARY,FDESC,,80)
+33 SET Y=0
FOR
SET Y=$ORDER(FDARY(Y))
if 'Y
QUIT
Begin DoDot:2
+34 SET ^TMP($JOB,"WP",Y)=$GET(FDARY(Y))
End DoDot:2
+35 DO WP^DIE(52.45,NIEN_",",1,"K","^TMP($J,""WP"")")
+36 KILL NIEN,^TMP($JOB,"WP"),FDARY,FDESC
End DoDot:1
+37 QUIT
+38 ; convert 52.45, field .03 from a set of codes into two separate free text fields
CONV5245 ;
+1 NEW IEN,A,CDESC,FDA
+2 SET IEN=0
FOR
SET IEN=$ORDER(^PS(52.45,IEN))
if 'IEN
QUIT
Begin DoDot:1
+3 SET A=$$GET1^DIQ(52.45,IEN,.03,"E")
+4 SET CDESC=$SELECT(A="REA":"SERVICE REASON",A="RES":"SERVICE RESULT",A="PSC":"PROFESSIONAL SERVICE",A="ERX":"ERX STATUS",A="DCS":"DRUG COVERAGE",1:"")
+5 IF CDESC=""
SET CDESC=$SELECT(A="PAV":"PRIOR AUTHORIZATION",A="CAQ":"CO-AGENT QUALIFIER",A="REJ":"REJECT REASON",A="REM":"REMOVAL REASON",A="DDB":"DRUG DB QUALIFIER",A="CLQ":"CODE LIST QUALIFIER",A="ERR":"ERROR",1:"")
+6 SET FDA(52.45,IEN_",",.04)=CDESC
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:1
+7 QUIT
ERXPOP ;
+1 NEW I,DONE,NIEN,ELINE,ECODE,EDESC,ELONG,EIEN,TYPE,SUB,CTTEXT,FDA,Y,FDARY,NIEN
+2 FOR TYPE="QCQ","PAY","CIQ","PCQ","CAQ","ACR","DDB","ICQ","PQC","ERX","MRC","MRSC","CLQ"
Begin DoDot:1
+3 SET SUB=TYPE
+4 IF TYPE="QCQ"
SET CTTEXT="QUANTITY CODE LIST QUALIFIER"
+5 IF TYPE="PAY"
SET CTTEXT="PAYER TYPE"
+6 IF TYPE="CIQ"
SET CTTEXT="COMPOUND INGREDIENT PRODUCT CODE QUALIFIER"
+7 IF TYPE="PCQ"
SET CTTEXT="PATIENT CODIFIED NOTE QUALIFIER"
+8 IF TYPE="CAQ"
SET CTTEXT="CO-AGENT QUALIFIER"
+9 IF TYPE="ACR"
SET CTTEXT="ALTERNATE CONTACT RELATIONSHIP"
+10 IF TYPE="DDB"
SET CTTEXT="DRUG DB QUALIFIER"
+11 IF TYPE="ICQ"
SET CTTEXT="INGREDIENT CODE QUALIFIER"
+12 IF TYPE="PQC"
SET CTTEXT="PRODUCT QUALIFIER CODE"
+13 IF TYPE="ERX"
SET CTTEXT="ERX STATUS"
+14 IF TYPE="MRC"
SET CTTEXT="MESSAGE REQUEST CODE"
+15 IF TYPE="MRSC"
SET CTTEXT="MESSAGE REQUEST SUB-CODE"
+16 IF TYPE="CLQ"
SET CTTEXT="CODE LIST QUALIFIER"
+17 SET DONE=0
+18 FOR I=1:1
Begin DoDot:2
+19 KILL NIEN
+20 SET ELINE=$GET(^TMP("PSO581PO",TYPE,I,0))
+21 IF ELINE=" Q"!(ELINE="")
SET DONE=1
QUIT
+22 SET ECODE=$PIECE(ELINE,U)
SET EDESC=$PIECE(ELINE,U,2)
SET ELONG=$PIECE(ELINE,U,3)
+23 IF $DATA(^PS(52.45,"C",SUB,ECODE))
Begin DoDot:3
+24 SET EIEN=$ORDER(^PS(52.45,"C",SUB,ECODE,0))
if 'EIEN
QUIT
+25 SET FDA(52.45,EIEN_",",.01)=ECODE
+26 SET FDA(52.45,EIEN_",",.02)=EDESC
+27 SET FDA(52.45,EIEN_",",.03)=SUB
+28 SET FDA(52.45,EIEN_",",.04)=CTTEXT
+29 DO FILE^DIE(,"FDA")
KILL FDA
+30 DO TXT2ARY^PSOERXD1(.FDARY,ELONG,,80)
+31 SET Y=0
FOR
SET Y=$ORDER(FDARY(Y))
if 'Y
QUIT
Begin DoDot:4
+32 SET ^TMP($JOB,"WP",Y)=$GET(FDARY(Y))
End DoDot:4
+33 DO WP^DIE(52.45,EIEN_",",1,"K","^TMP($J,""WP"")")
+34 KILL NIEN,^TMP($JOB,"WP"),FDARY,ELONG
End DoDot:3
QUIT
+35 SET FDA(52.45,"+1,",.01)=ECODE
+36 SET FDA(52.45,"+1,",.02)=EDESC
+37 SET FDA(52.45,"+1,",.03)=SUB
+38 SET FDA(52.45,"+1,",.04)=CTTEXT
+39 DO UPDATE^DIE(,"FDA","NIEN")
KILL FDA
+40 SET REC=$ORDER(NIEN(0))
SET NIEN=$GET(NIEN(REC))
+41 DO TXT2ARY^PSOERXD1(.FDARY,ELONG,,80)
+42 SET Y=0
FOR
SET Y=$ORDER(FDARY(Y))
if 'Y
QUIT
Begin DoDot:3
+43 SET ^TMP($JOB,"WP",Y)=$GET(FDARY(Y))
End DoDot:3
+44 DO WP^DIE(52.45,NIEN_",",1,"K","^TMP($J,""WP"")")
+45 KILL NIEN,^TMP($JOB,"WP"),FDARY,ELONG
End DoDot:2
if DONE
QUIT
End DoDot:1
+46 QUIT
+47 ; change eRx status entries from 'refill' to 'rx renewal'
REFREN ;
+1 NEW CODE,SIEN,STAT,FDA,NSTAT,P1,P2
+2 SET CODE=""
FOR
SET CODE=$ORDER(^PS(52.45,"C","ERX",CODE))
if CODE=""
QUIT
Begin DoDot:1
+3 SET SIEN=0
FOR
SET SIEN=$ORDER(^PS(52.45,"C","ERX",CODE,SIEN))
if 'SIEN
QUIT
Begin DoDot:2
+4 IF CODE="IRA"
SET FDA(52.45,SIEN_",",.02)="INBOUND RXRENEWAL ERROR ACKNOWLEDGED"
DO FILE^DIE(,"FDA")
KILL FDA
QUIT
+5 ; only convert the refill/renewal status entries
+6 if $EXTRACT(CODE)'="R"
QUIT
+7 SET STAT=$$GET1^DIQ(52.45,SIEN,.02,"E")
+8 if STAT'["REFILL"
QUIT
+9 ; the word 'refill' only occurs once per instance, so simply gathering 2 pieces is sufficient for this activity
+10 SET P1=$PIECE(STAT,"REFILL",1)
SET P2=$PIECE(STAT,"REFILL",2)
+11 SET NSTAT=P1_"RXRENEWAL"_P2
+12 SET FDA(52.45,SIEN_",",.02)=NSTAT
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:2
End DoDot:1
+13 QUIT
