APSQUTL ;IHS/DSD/ENM/POC - UTIL TO SET VARIOUS FIELDS [ 05/22/2001 1:24 PM ];18-Apr-2006 21:56;SM
;;7.0;IHS PHARMACY MODIFICATIONS;**1004**;04/10/2001
;FROM FIELD # OF FILE #
EXPL ;THIS IS THE EXPLANATION
W !,"THE ENTRY IN THIS FIELD DETERMINES WHETHER A SIGNATURE LABEL IS PRINTED."
W !,"A COMBINATION OF CODES CAN BE USED EXCEPT FOR 'A' OR 'N'."
W !
;
LIST F I=2:1 S VAR=$P($T(LIST+I),";;",2) Q:VAR="" W !,VAR
K VAR Q
;;D=MEDICAID PRESCRIPTIONS
;;R=MEDICARE PRESCRIPTIONS
;;P=PRIVATE INSURANCE PRESCRIPTIONS
;;A=ALL PRESCRIPTIONS
;;N=NO PRESCRIPTIONS
;;A CAN ONLY BE CHOSEN BY ITSELF
;;N CAN ONLY BE CHOSEN BY ITSELF
;
Q
EDIT ;THIS IS THE EDIT
S X=$TR(X,"BCEFGHIJKLMOQSTUVWXYZ")
I X'?1.3A K X W "GOT TO BE 1 TO 3 CHARACTERS" Q
S:X["A" X="A"
S:X["N" X="N"
I X["DD"!(X["RR")!(X["PP") K X Q
W " "_X
Q
;
NDC ;INPUT TRANSFORM FOR NDC FIELD OF RX
;IHS/OKCAO/POC 4/10/2001
K:+X=0 X
;I $D(X) S:X?4N1"-"4N1"-"2N X="0"_X
;I $D(X) S:X?5N1"-"3N1"-"2N X=$P(X,"-",1)_"-0"_$P(X,"-",2)_"-"_$P(X,"-",3)
;I $D(X) S:X?4N1"-"3N1"-"2N X="0"_$P(X,"-",1)_"-0"_$P(X,"-",2)_"-"_$P(X,"-",3)
;BETTER 5/21/2001 IHS/OKCAO/POC
I $D(X),X?1.5N1"-"1.4N1"-"1.2N D
.N PIECE1,PIECE2,PIECE3,LEN1,LEN2,LEN3
.S PIECE1=$P(X,"-",1) S LEN1=$L(PIECE1) S PIECE1=$E("00000"_PIECE1,LEN1+1,99)
.S PIECE2=$P(X,"-",2) S LEN2=$L(PIECE2) S PIECE2=$E("0000"_PIECE2,LEN2+1,99)
.S PIECE3=$P(X,"-",3) S LEN3=$L(PIECE3) S PIECE3=$E("00"_PIECE3,LEN3+1,99)
.S X=PIECE1_"-"_PIECE2_"-"_PIECE3
I $D(X) S:((X'["-")&($L(X)=10)) X="0"_X
I $D(X) S:((X'["-")&($L(X)=11)) X=$E(X,1,5)_"-"_$E(X,6,9)_"-"_$E(X,10,11)
I $D(X) K:X'?5N1"-"4N1"-"2N X
Q
;
;LOOKUP UP XREF-THIS XREF TAKES AN 11 DIGIT NUMBER AND MAKE A XREF OF 10 DIGITS IF FIRST TWO DIGITS "00" SO 00123123412 WOULD BE 0123123412
;
SETLKU ;EP
N NUM,PIECE
S PIECE=$P(X,"-")
S NUM=$TR(X,"-")
I $L(PIECE)=5,$E(PIECE,1,2)="00" S ^PSDRUG("LKU",$E(NUM,2,11),DA)=""
Q
;
KILLKU ;EP
N NUM,PIECE
S PIECE=$P(X,"-")
S NUM=$TR(X,"-")
I $L(PIECE)=5,$E(PIECE,1,2)="00" K ^PSDRUG("LKU",$E(NUM,2,11),DA)
Q
APSQUTL ;IHS/DSD/ENM/POC - UTIL TO SET VARIOUS FIELDS [ 05/22/2001 1:24 PM ];18-Apr-2006 21:56;SM
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1004**;04/10/2001
+2 ;FROM FIELD # OF FILE #
EXPL ;THIS IS THE EXPLANATION
+1 WRITE !,"THE ENTRY IN THIS FIELD DETERMINES WHETHER A SIGNATURE LABEL IS PRINTED."
+2 WRITE !,"A COMBINATION OF CODES CAN BE USED EXCEPT FOR 'A' OR 'N'."
+3 WRITE !
+4 ;
LIST FOR I=2:1
SET VAR=$PIECE($TEXT(LIST+I),";;",2)
IF VAR=""
QUIT
WRITE !,VAR
+1 KILL VAR
QUIT
+2 ;;D=MEDICAID PRESCRIPTIONS
+3 ;;R=MEDICARE PRESCRIPTIONS
+4 ;;P=PRIVATE INSURANCE PRESCRIPTIONS
+5 ;;A=ALL PRESCRIPTIONS
+6 ;;N=NO PRESCRIPTIONS
+7 ;;A CAN ONLY BE CHOSEN BY ITSELF
+8 ;;N CAN ONLY BE CHOSEN BY ITSELF
+9 ;
+10 QUIT
EDIT ;THIS IS THE EDIT
+1 SET X=$TRANSLATE(X,"BCEFGHIJKLMOQSTUVWXYZ")
+2 IF X'?1.3A
KILL X
WRITE "GOT TO BE 1 TO 3 CHARACTERS"
QUIT
+3 IF X["A"
SET X="A"
+4 IF X["N"
SET X="N"
+5 IF X["DD"!(X["RR")!(X["PP")
KILL X
QUIT
+6 WRITE " "_X
+7 QUIT
+8 ;
NDC ;INPUT TRANSFORM FOR NDC FIELD OF RX
+1 ;IHS/OKCAO/POC 4/10/2001
+2 IF +X=0
KILL X
+3 ;I $D(X) S:X?4N1"-"4N1"-"2N X="0"_X
+4 ;I $D(X) S:X?5N1"-"3N1"-"2N X=$P(X,"-",1)_"-0"_$P(X,"-",2)_"-"_$P(X,"-",3)
+5 ;I $D(X) S:X?4N1"-"3N1"-"2N X="0"_$P(X,"-",1)_"-0"_$P(X,"-",2)_"-"_$P(X,"-",3)
+6 ;BETTER 5/21/2001 IHS/OKCAO/POC
+7 IF $DATA(X)
IF X?1.5N1"-"1.4N1"-"1.2N
Begin DoDot:1
+8 NEW PIECE1,PIECE2,PIECE3,LEN1,LEN2,LEN3
+9 SET PIECE1=$PIECE(X,"-",1)
SET LEN1=$LENGTH(PIECE1)
SET PIECE1=$EXTRACT("00000"_PIECE1,LEN1+1,99)
+10 SET PIECE2=$PIECE(X,"-",2)
SET LEN2=$LENGTH(PIECE2)
SET PIECE2=$EXTRACT("0000"_PIECE2,LEN2+1,99)
+11 SET PIECE3=$PIECE(X,"-",3)
SET LEN3=$LENGTH(PIECE3)
SET PIECE3=$EXTRACT("00"_PIECE3,LEN3+1,99)
+12 SET X=PIECE1_"-"_PIECE2_"-"_PIECE3
End DoDot:1
+13 IF $DATA(X)
IF ((X'["-")&($LENGTH(X)=10))
SET X="0"_X
+14 IF $DATA(X)
IF ((X'["-")&($LENGTH(X)=11))
SET X=$EXTRACT(X,1,5)_"-"_$EXTRACT(X,6,9)_"-"_$EXTRACT(X,10,11)
+15 IF $DATA(X)
IF X'?5N1"-"4N1"-"2N
KILL X
+16 QUIT
+17 ;
+18 ;LOOKUP UP XREF-THIS XREF TAKES AN 11 DIGIT NUMBER AND MAKE A XREF OF 10 DIGITS IF FIRST TWO DIGITS "00" SO 00123123412 WOULD BE 0123123412
+19 ;
SETLKU ;EP
+1 NEW NUM,PIECE
+2 SET PIECE=$PIECE(X,"-")
+3 SET NUM=$TRANSLATE(X,"-")
+4 IF $LENGTH(PIECE)=5
IF $EXTRACT(PIECE,1,2)="00"
SET ^PSDRUG("LKU",$EXTRACT(NUM,2,11),DA)=""
+5 QUIT
+6 ;
KILLKU ;EP
+1 NEW NUM,PIECE
+2 SET PIECE=$PIECE(X,"-")
+3 SET NUM=$TRANSLATE(X,"-")
+4 IF $LENGTH(PIECE)=5
IF $EXTRACT(PIECE,1,2)="00"
KILL ^PSDRUG("LKU",$EXTRACT(NUM,2,11),DA)
+5 QUIT
