APSPFNC4 ;IHS/MSC/DKM E-Prescribing Support ;10-Sep-2013 13:59;PLS
;;7.0;IHS PHARMACY MODIFICATIONS;**1007,1009,1016**;Sep 23, 2004;Build 74
;==============================================================
; Pharmacy List Update Functions
; Patch 1016 added XUMF variable
PHLFIL(DIR,FIL,MAX) ; EP - Import updates from a file
N ERR,POP,CNT,XUMF
D OPEN^%ZISH(,DIR,FIL,"R")
I POP W "File not found",! Q
S ERR="",MAX=+$G(MAX)
S XUMF=1
F CNT=1:1 D Q:POP!(CNT=MAX)
.N REC,LP
.U IO
.D READNXT^%ZISH(.REC)
.I '$L($G(REC)) S POP=1 Q
.S LP=0
.F S LP=$O(REC(LP)) Q:'LP S REC=REC_REC(LP)
.U IO(0)
.S ERR=$$PHLREC(REC)
.W:$L(ERR) CNT,": ",ERR,!
D CLOSE^%ZISH()
Q
PHLGBL(GBL) ; EP - Import updates from a local or global array
N LP,ERR
S (LP,ERR)=""
F S LP=$O(@GBL@(LP)) Q:'$L(LP) S ERR=$$PHLREC(@GBL@(LP)) Q:$L(ERR)
Q ERR
PHLREC(REC,DEBUG) ; EP - Import updates from a single record
N LP,CTL,ERR,FDA,NCPDPID,IEN,SFN,SFNC,STNAME,IENS
S NCPDPID=$TR($E(REC,1,7)," "),SFNC=1,DEBUG=$G(DEBUG)
Q:'$L(NCPDPID) "Missing NCPDP ID"
S STNAME=$TR($E(REC,43,78)," ")
Q:'$L(STNAME) "Missing Store Name"
S IEN=$O(^APSPOPHM("C",NCPDPID,0))
I IEN D DELSPEC(IEN)
S FDA=$NA(FDA(9009033.9,$S(IEN:IEN,1:"+1")_","))
F LP=0:1 S CTL=$P($T(CTL44+LP),";;",2,99) Q:'$L(CTL) D Q:$D(ERR)
.N X,FNUM,FNAM
.S FNAM=$P(CTL,";"),FNUM=$P(CTL,";",2)
.S X=$P(CTL,";",3),X=$E(REC,X,X+$P(CTL,";",4)-1)
.F Q:$A(X,$L(X))'=32 S X=$E(X,1,$L(X)-1)
.X $P(CTL,";",5)
.I DEBUG U IO(0) W $P(CTL,";"),"=",X,!
.I $D(ERR) S ERR="Error processing field "_FNAM_": "_ERR
.E Q:'$L(X)
.E I FNUM'[":" S @FDA@(FNUM)=X
.E D
..S SFN=+FNUM,FNUM=$P(FNUM,":",2)
..;S:'$D(SFN(SFN)) SFNC=SFNC+1,SFN(SFN)="+"_SFNC_","_$S(IEN:IEN,1:"+1")_","
..S:FNUM=.01 SFNC=SFNC+1,IENS="+"_SFNC_","_$S(IEN:IEN,1:"+1")_","
..Q:'$L($G(IENS))
..S:FNUM=.01!$D(FDA(SFN,IENS,.01)) FDA(SFN,IENS,FNUM)=X
Q:$D(ERR) ERR
K:IEN ^APSPOPHM(IEN,3),^(4)
D UPDATE^DIE("E","FDA",,"ERR")
I $G(ERR("DIERR",1)) D Q ERR
.S LP=0,ERR=""
.F S LP=$O(ERR("DIERR",1,"TEXT",LP)) Q:'LP S ERR=ERR_$S($L(ERR):" ",1:"")_ERR("DIERR",1,"TEXT",LP)
Q ""
; Convert SS date format to FM
DT(X) S:$L(X) X=+($TR($P(X,"T"),"-")-17000000_"."_$TR($P($P(X,"T",2,99),"."),":"))
Q
; Normalize phone format
PHONE(X) S X=$TR(X,"X() -","x")
S:X'?10N.(1"x"1.14N) X=""
Q
SPEC(X) ; Put specialty into upper case
D SCHAR(.X)
S X=$$UP^XLFSTR(X)
Q
SCHAR(X) ; Remove characters that interfere with fileman
S X=$TR(X,"^&","")
Q
DELSPEC(IEN) ;Delete exisiting specialties
K NUM,DA,DIK
S NUM=0 F S NUM=$O(^APSPOPHM(IEN,8,NUM)) Q:NUM="" D
.S DA(1)=IEN,DA=NUM
.S DIK="^APSPOPHM(IEN,8,"
.D ^DIK
Q
;Import control data
;Format is:
;;<SS field name><FM field #><offset><length><transform>
CTL ;;NCPDPID;.02;1;7
;;StoreNumber;.03;8;35
;;ReferenceNumberAlt1;9009033.94:.01;43;35
;;ReferenceNumberAlt1Qualifier;9009033.94:.02;78;3
;;StoreName;.01;81;35
;;StoreName;.1;81;35
;;AddressLine1;1.1;116;35
;;AddressLine2;1.2;151;35
;;City;1.3;186;35
;;State;1.4;221;2
;;Zip;1.5;223;11;S X=$E(X,1,5)
;;PhonePrimary;2.1;234;25;D PHONE(.X)
;;Fax;2.2;259;25;D PHONE(.X)
;;Email;2.3;284;80
;;PhoneAlt1;9009033.93:.01;364;25;D PHONE(.X)
;;PhoneAlt1Qualifier;9009033.93:.02;389;3
;;PhoneAlt2;9009033.93:.01;392;25;D PHONE(.X)
;;PhoneAlt2Qualifier;9009033.93:.02;417;3
;;PhoneAlt3;9009033.93:.01;420;25;D PHONE(.X)
;;PhoneAlt3Qualifier;9009033.93:.02;445;3
;;PhoneAlt4;9009033.93:.01;448;25;D PHONE(.X)
;;PhoneAlt4Qualifier;9009033.93:.02;473;3
;;PhoneAlt5;9009033.93:.01;476;25;D PHONE(.X)
;;PhoneAlt5Qualifier;9009033.93:.02;501;3
;;ActiveStartTime;7.1;504;22;D DT(.X)
;;ActiveEndTime;7.2;526;22;D DT(.X)
;;ServiceLevel;.05;548;5
;;PartnerAccount;7.3;553;35
;;LastModifiedDate;7.4;588;22;D DT(.X)
;;TwentyFourHourFlag;.06;610;1
;;CrossStreet;1.6;611;35
;;OldServiceLevel;5.1;647;5;S X=$S(X<0:"@",1:X)
;;TextServiceLevel;5.2;652;100
;;TextServiceLevelChange;5.3;752;100
;;NPI;.04;857;10
;;
;Import control data for version 4.4
;Format is:
;;<SS field name><FM field #><offset><length><transform>
CTL44 ;;NCPDPID;.02;1;7;D SCHAR(.X)
;;StoreNumber;.03;8;35;D SCHAR(.X)
;;StoreName;.01;43;35;D SCHAR(.X)
;;StoreName;.1;43;35;D SCHAR(.X)
;;AddressLine1;1.1;78;35;D SCHAR(.X)
;;AddressLine2;1.2;113;35;D SCHAR(.X)
;;City;1.3;148;35;D SCHAR(.X)
;;State;1.4;183;2;D SCHAR(.X)
;;Zip;1.5;185;11;D SCHAR(.X) S X=$E(X,1,5)
;;PhonePrimary;2.1;196;25;D PHONE(.X)
;;Fax;2.2;221;25;D PHONE(.X)
;;Email;2.3;246;80;D SCHAR(.X)
;;PhoneAlt1;9009033.93:.01;326;25;D PHONE(.X)
;;PhoneAlt1Qualifier;9009033.93:.02;351;3;D SCHAR(.X)
;;PhoneAlt2;9009033.93:.01;354;25;D PHONE(.X)
;;PhoneAlt2Qualifier;9009033.93:.02;379;3;D SCHAR(.X)
;;PhoneAlt3;9009033.93:.01;382;25;D PHONE(.X)
;;PhoneAlt3Qualifier;9009033.93:.02;407;3;D SCHAR(.X)
;;PhoneAlt4;9009033.93:.01;410;25;D PHONE(.X)
;;PhoneAlt4Qualifier;9009033.93:.02;435;3;D SCHAR(.X)
;;PhoneAlt5;9009033.93:.01;438;25;D PHONE(.X)
;;PhoneAlt5Qualifier;9009033.93:.02;463;3;D SCHAR(.X)
;;ActiveStartTime;7.1;466;22;D DT(.X)
;;ActiveEndTime;7.2;488;22;D DT(.X)
;;ServiceLevel;.05;510;5;D SCHAR(.X)
;;PartnerAccount;7.3;515;35;D SCHAR(.X)
;;LastModifiedDate;7.4;550;22;D DT(.X)
;;CrossStreet;1.6;572;35;D SCHAR(.X)
;;RecordChange;6.1;607;1;D SCHAR(.X)
;;OldServiceLevel;5.1;608;5;D SCHAR(.X) S X=$S(X<0:"@",1:X)
;;TextServiceLevel;5.2;613;100;D SCHAR(.X)
;;TextServiceLevelChange;5.3;713;100;D SCHAR(.X)
;;Version;6.2;813;5;D SCHAR(.X)
;;NPI;.04;818;10;D SCHAR(.X)
;;SpecialtyType1;9009033.98:.01;828;35;D SPEC(.X)
;;SpecialtyType2;9009033.98:.01;863;35;D SPEC(.X)
;;SpecialtyType3;9009033.98:.01;898;35;D SPEC(.X)
;;SpecialtyType4;9009033.98:.01;933;35;D SPEC(.X)
;;MedicareNumber;6.3;1038;35;D SCHAR(.X)
;;MedicaidNumber;6.4;1073;35;D SCHAR(.X)
;;
APSPFNC4 ;IHS/MSC/DKM E-Prescribing Support ;10-Sep-2013 13:59;PLS
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1007,1009,1016**;Sep 23, 2004;Build 74
+2 ;==============================================================
+3 ; Pharmacy List Update Functions
+4 ; Patch 1016 added XUMF variable
PHLFIL(DIR,FIL,MAX) ; EP - Import updates from a file
+1 NEW ERR,POP,CNT,XUMF
+2 DO OPEN^%ZISH(,DIR,FIL,"R")
+3 IF POP
WRITE "File not found",!
QUIT
+4 SET ERR=""
SET MAX=+$GET(MAX)
+5 SET XUMF=1
+6 FOR CNT=1:1
Begin DoDot:1
+7 NEW REC,LP
+8 USE IO
+9 DO READNXT^%ZISH(.REC)
+10 IF '$LENGTH($GET(REC))
SET POP=1
QUIT
+11 SET LP=0
+12 FOR
SET LP=$ORDER(REC(LP))
IF 'LP
QUIT
SET REC=REC_REC(LP)
+13 USE IO(0)
+14 SET ERR=$$PHLREC(REC)
+15 IF $LENGTH(ERR)
WRITE CNT,": ",ERR,!
End DoDot:1
IF POP!(CNT=MAX)
QUIT
+16 DO CLOSE^%ZISH()
+17 QUIT
PHLGBL(GBL) ; EP - Import updates from a local or global array
+1 NEW LP,ERR
+2 SET (LP,ERR)=""
+3 FOR
SET LP=$ORDER(@GBL@(LP))
IF '$LENGTH(LP)
QUIT
SET ERR=$$PHLREC(@GBL@(LP))
IF $LENGTH(ERR)
QUIT
+4 QUIT ERR
PHLREC(REC,DEBUG) ; EP - Import updates from a single record
+1 NEW LP,CTL,ERR,FDA,NCPDPID,IEN,SFN,SFNC,STNAME,IENS
+2 SET NCPDPID=$TRANSLATE($EXTRACT(REC,1,7)," ")
SET SFNC=1
SET DEBUG=$GET(DEBUG)
+3 IF '$LENGTH(NCPDPID)
QUIT "Missing NCPDP ID"
+4 SET STNAME=$TRANSLATE($EXTRACT(REC,43,78)," ")
+5 IF '$LENGTH(STNAME)
QUIT "Missing Store Name"
+6 SET IEN=$ORDER(^APSPOPHM("C",NCPDPID,0))
+7 IF IEN
DO DELSPEC(IEN)
+8 SET FDA=$NAME(FDA(9009033.9,$SELECT(IEN:IEN,1:"+1")_","))
+9 FOR LP=0:1
SET CTL=$PIECE($TEXT(CTL44+LP),";;",2,99)
IF '$LENGTH(CTL)
QUIT
Begin DoDot:1
+10 NEW X,FNUM,FNAM
+11 SET FNAM=$PIECE(CTL,";")
SET FNUM=$PIECE(CTL,";",2)
+12 SET X=$PIECE(CTL,";",3)
SET X=$EXTRACT(REC,X,X+$PIECE(CTL,";",4)-1)
+13 FOR
IF $ASCII(X,$LENGTH(X))'=32
QUIT
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+14 XECUTE $PIECE(CTL,";",5)
+15 IF DEBUG
USE IO(0)
WRITE $PIECE(CTL,";"),"=",X,!
+16 IF $DATA(ERR)
SET ERR="Error processing field "_FNAM_": "_ERR
+17 IF '$TEST
IF '$LENGTH(X)
QUIT
+18 IF '$TEST
IF FNUM'[":"
SET @FDA@(FNUM)=X
+19 IF '$TEST
Begin DoDot:2
+20 SET SFN=+FNUM
SET FNUM=$PIECE(FNUM,":",2)
+21 ;S:'$D(SFN(SFN)) SFNC=SFNC+1,SFN(SFN)="+"_SFNC_","_$S(IEN:IEN,1:"+1")_","
+22 IF FNUM=.01
SET SFNC=SFNC+1
SET IENS="+"_SFNC_","_$SELECT(IEN:IEN,1:"+1")_","
+23 IF '$LENGTH($GET(IENS))
QUIT
+24 IF FNUM=.01!$DATA(FDA(SFN,IENS,.01))
SET FDA(SFN,IENS,FNUM)=X
End DoDot:2
End DoDot:1
IF $DATA(ERR)
QUIT
+25 IF $DATA(ERR)
QUIT ERR
+26 IF IEN
KILL ^APSPOPHM(IEN,3),^(4)
+27 DO UPDATE^DIE("E","FDA",,"ERR")
+28 IF $GET(ERR("DIERR",1))
Begin DoDot:1
+29 SET LP=0
SET ERR=""
+30 FOR
SET LP=$ORDER(ERR("DIERR",1,"TEXT",LP))
IF 'LP
QUIT
SET ERR=ERR_$SELECT($LENGTH(ERR):" ",1:"")_ERR("DIERR",1,"TEXT",LP)
End DoDot:1
QUIT ERR
+31 QUIT ""
+32 ; Convert SS date format to FM
DT(X) IF $LENGTH(X)
SET X=+($TRANSLATE($PIECE(X,"T"),"-")-17000000_"."_$TRANSLATE($PIECE($PIECE(X,"T",2,99),"."),":"))
+1 QUIT
+2 ; Normalize phone format
PHONE(X) SET X=$TRANSLATE(X,"X() -","x")
+1 IF X'?10N.(1"x"1.14N)
SET X=""
+2 QUIT
SPEC(X) ; Put specialty into upper case
+1 DO SCHAR(.X)
+2 SET X=$$UP^XLFSTR(X)
+3 QUIT
SCHAR(X) ; Remove characters that interfere with fileman
+1 SET X=$TRANSLATE(X,"^&","")
+2 QUIT
DELSPEC(IEN) ;Delete exisiting specialties
+1 KILL NUM,DA,DIK
+2 SET NUM=0
FOR
SET NUM=$ORDER(^APSPOPHM(IEN,8,NUM))
IF NUM=""
QUIT
Begin DoDot:1
+3 SET DA(1)=IEN
SET DA=NUM
+4 SET DIK="^APSPOPHM(IEN,8,"
+5 DO ^DIK
End DoDot:1
+6 QUIT
+7 ;Import control data
+8 ;Format is:
+9 ;;<SS field name><FM field #><offset><length><transform>
CTL ;;NCPDPID;.02;1;7
+1 ;;StoreNumber;.03;8;35
+2 ;;ReferenceNumberAlt1;9009033.94:.01;43;35
+3 ;;ReferenceNumberAlt1Qualifier;9009033.94:.02;78;3
+4 ;;StoreName;.01;81;35
+5 ;;StoreName;.1;81;35
+6 ;;AddressLine1;1.1;116;35
+7 ;;AddressLine2;1.2;151;35
+8 ;;City;1.3;186;35
+9 ;;State;1.4;221;2
+10 ;;Zip;1.5;223;11;S X=$E(X,1,5)
+11 ;;PhonePrimary;2.1;234;25;D PHONE(.X)
+12 ;;Fax;2.2;259;25;D PHONE(.X)
+13 ;;Email;2.3;284;80
+14 ;;PhoneAlt1;9009033.93:.01;364;25;D PHONE(.X)
+15 ;;PhoneAlt1Qualifier;9009033.93:.02;389;3
+16 ;;PhoneAlt2;9009033.93:.01;392;25;D PHONE(.X)
+17 ;;PhoneAlt2Qualifier;9009033.93:.02;417;3
+18 ;;PhoneAlt3;9009033.93:.01;420;25;D PHONE(.X)
+19 ;;PhoneAlt3Qualifier;9009033.93:.02;445;3
+20 ;;PhoneAlt4;9009033.93:.01;448;25;D PHONE(.X)
+21 ;;PhoneAlt4Qualifier;9009033.93:.02;473;3
+22 ;;PhoneAlt5;9009033.93:.01;476;25;D PHONE(.X)
+23 ;;PhoneAlt5Qualifier;9009033.93:.02;501;3
+24 ;;ActiveStartTime;7.1;504;22;D DT(.X)
+25 ;;ActiveEndTime;7.2;526;22;D DT(.X)
+26 ;;ServiceLevel;.05;548;5
+27 ;;PartnerAccount;7.3;553;35
+28 ;;LastModifiedDate;7.4;588;22;D DT(.X)
+29 ;;TwentyFourHourFlag;.06;610;1
+30 ;;CrossStreet;1.6;611;35
+31 ;;OldServiceLevel;5.1;647;5;S X=$S(X<0:"@",1:X)
+32 ;;TextServiceLevel;5.2;652;100
+33 ;;TextServiceLevelChange;5.3;752;100
+34 ;;NPI;.04;857;10
+35 ;;
+36 ;Import control data for version 4.4
+37 ;Format is:
+38 ;;<SS field name><FM field #><offset><length><transform>
CTL44 ;;NCPDPID;.02;1;7;D SCHAR(.X)
+1 ;;StoreNumber;.03;8;35;D SCHAR(.X)
+2 ;;StoreName;.01;43;35;D SCHAR(.X)
+3 ;;StoreName;.1;43;35;D SCHAR(.X)
+4 ;;AddressLine1;1.1;78;35;D SCHAR(.X)
+5 ;;AddressLine2;1.2;113;35;D SCHAR(.X)
+6 ;;City;1.3;148;35;D SCHAR(.X)
+7 ;;State;1.4;183;2;D SCHAR(.X)
+8 ;;Zip;1.5;185;11;D SCHAR(.X) S X=$E(X,1,5)
+9 ;;PhonePrimary;2.1;196;25;D PHONE(.X)
+10 ;;Fax;2.2;221;25;D PHONE(.X)
+11 ;;Email;2.3;246;80;D SCHAR(.X)
+12 ;;PhoneAlt1;9009033.93:.01;326;25;D PHONE(.X)
+13 ;;PhoneAlt1Qualifier;9009033.93:.02;351;3;D SCHAR(.X)
+14 ;;PhoneAlt2;9009033.93:.01;354;25;D PHONE(.X)
+15 ;;PhoneAlt2Qualifier;9009033.93:.02;379;3;D SCHAR(.X)
+16 ;;PhoneAlt3;9009033.93:.01;382;25;D PHONE(.X)
+17 ;;PhoneAlt3Qualifier;9009033.93:.02;407;3;D SCHAR(.X)
+18 ;;PhoneAlt4;9009033.93:.01;410;25;D PHONE(.X)
+19 ;;PhoneAlt4Qualifier;9009033.93:.02;435;3;D SCHAR(.X)
+20 ;;PhoneAlt5;9009033.93:.01;438;25;D PHONE(.X)
+21 ;;PhoneAlt5Qualifier;9009033.93:.02;463;3;D SCHAR(.X)
+22 ;;ActiveStartTime;7.1;466;22;D DT(.X)
+23 ;;ActiveEndTime;7.2;488;22;D DT(.X)
+24 ;;ServiceLevel;.05;510;5;D SCHAR(.X)
+25 ;;PartnerAccount;7.3;515;35;D SCHAR(.X)
+26 ;;LastModifiedDate;7.4;550;22;D DT(.X)
+27 ;;CrossStreet;1.6;572;35;D SCHAR(.X)
+28 ;;RecordChange;6.1;607;1;D SCHAR(.X)
+29 ;;OldServiceLevel;5.1;608;5;D SCHAR(.X) S X=$S(X<0:"@",1:X)
+30 ;;TextServiceLevel;5.2;613;100;D SCHAR(.X)
+31 ;;TextServiceLevelChange;5.3;713;100;D SCHAR(.X)
+32 ;;Version;6.2;813;5;D SCHAR(.X)
+33 ;;NPI;.04;818;10;D SCHAR(.X)
+34 ;;SpecialtyType1;9009033.98:.01;828;35;D SPEC(.X)
+35 ;;SpecialtyType2;9009033.98:.01;863;35;D SPEC(.X)
+36 ;;SpecialtyType3;9009033.98:.01;898;35;D SPEC(.X)
+37 ;;SpecialtyType4;9009033.98:.01;933;35;D SPEC(.X)
+38 ;;MedicareNumber;6.3;1038;35;D SCHAR(.X)
+39 ;;MedicaidNumber;6.4;1073;35;D SCHAR(.X)
+40 ;;
