- 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
