PXVP201 ;BPIOFO/CLR - Environment routines ; 9/29/14 10:59am
;;1.0;PCE PATIENT CARE ENCOUNTER;**201**;Aug 12, 1996;Build 41
;
Q
PRETRAN ;Load tables
I $G(DUZ("AG"))'="V" Q
M @XPDGREF@("PXVMAP")=^XTMP("PXVMAP")
M @XPDGREF@("PXVCVX")=^XTMP("PXVCVX")
Q
;
PRE ;
N DA,DIK,IEN
I $G(DUZ("AG"))'="V" Q
;check that site has no IMMUNIZATION IENs between 1000 and 2000
I '$D(^AUTTIVIS),($O(^AUTTIMM(1000))<2000) W !,"Invalid IEN in the IMMUNIZATION file - INSTALLATION ABORTED" S XPDABORT=1 Q
;delete data definitions in V IMMUNIZATION
F DA=.08,.09,.1,.11,.12,.13,.14,.15 S DIK="^DD(9000010.11,",DA(1)=9000010.11 D ^DIK
;delete IMM MANUFACTURER
I $D(^AUTTIMAN) S IEN=0,DIK="^AUTTIMAN(" D
.F S IEN=$O(^AUTTIMAN(IEN)) Q:IEN'>0 D
. . S DA=IEN D ^DIK
;delete VACCINE INFORMATION STATEMENT
I $D(^AUTTIVIS) S IEN=0,DIK="^AUTTIVIS(" D
.F S IEN=$O(^AUTTIVIS(IEN)) Q:IEN'>0 D
. . S DA=IEN D ^DIK
Q
;
POST ;Post installation
I $G(DUZ("AG"))'="V" Q ;do not install in non-VA environments
N ERRCNT,PXVCPDT,XUMF
K ^XTMP("PXVMAP"),^XTMP("PXVCVX"),^XTMP("PXVERR")
M ^XTMP("PXVMAP")=@XPDGREF@("PXVMAP")
M ^XTMP("PXVCVX")=@XPDGREF@("PXVCVX")
I '$D(^XTMP("PXVMAP"))!('$D(^XTMP("PXVCVX"))) W !,"Mapping table not loaded - INSTALLATION ABORTED" S XPDQUIT=2 Q
I '$D(^XTMP("PXVIMM")) M ^XTMP("PXVIMM","PXV")=^AUTTIMM
S PXVCPDT=$$FMADD^XLFDT(DT,10)
S ^XTMP("PXVMAP",0)=PXVCPDT_"^"_DT ;set purge ddt/creation dt
S ^XTMP("PXVCVX",0)=PXVCPDT_"^"_DT
S PXVCPDT=$$FMADD^XLFDT(DT,90)
S ^XTMP("PXVIMM",0)=PXVCPDT_"^"_DT
D DATA ;restores backup
D REINDX ;re-indexex "B" crossref
D MAP ;maps local entries to CVX code using data in ^XTMP("PXVMAP")
;Selects/updates standard entry for each CVX code
;using data in ^XTMP("PXVCVX")
D SELECT
D REMAIN ;updates non-standard entries
D MAIL ;sends email to installer
D MVDIAGS^PXVPST01 ;move data in V IMMUNIZATION
Q
;
MAP ;map local names to CVX codes
S XUMF=1
N PXVZ,PXVIEN,PXVERR,PXVC,I,PXVT
F I=0:0 S I=$O(^XTMP("PXVMAP",I)) Q:I'>0 D
. S PXVZ=$G(^XTMP("PXVMAP",I,0))
. F PXVIEN=0:0 S PXVIEN=$O(^AUTTIMM("B",$P(PXVZ,U),PXVIEN)) Q:PXVIEN="" D
. . S PXVC=$S($L($P(PXVZ,U,2))=1:"0"_($P(PXVZ,U,2)),1:$P(PXVZ,U,2))
. . S PXVT(9999999.14,+PXVIEN_",",.03)=PXVC
. . D UPDATE^DIE(,"PXVT",,"PXVERR")
. . I $D(PXVERR) D ERROR(.PXVERR)
Q
;
SELECT ;Select standard in local file entries with CVX code
N I,PXVSTIEN,PXVC,PXVZ,PXVOUT
F I=0:0 S I=$O(^XTMP("PXVCVX",I)) Q:I="" D
. S PXVZ=$G(^XTMP("PXVCVX",I,0))
. ;handles one overflow line
. S PXVZ=PXVZ_$G(^XTMP("PXVCVX",I,"OVF",1))
. S PXVC=$P(PXVZ,U),PXVC=$S($L(PXVC)=1:"0"_PXVC,1:PXVC)
. I '$D(^AUTTIMM("C",PXVC)) D Q
. . S PXVZ="0^"_PXVZ
. . S PXVOUT=$$STANDARD(PXVZ)
. ;get ien of standard entry
. S PXVSTIEN=$$ORDER(PXVC)
. S PXVZ=PXVSTIEN_"^"_PXVZ
. S PXVOUT=$$STANDARD(PXVZ)
Q
;
ORDER(CVX) ;determines precedence order for record
; 1: IEN<1000 & ACTIVE
; 2: IEN in local ns & ACTIVE
; 3: IEN in remote ns & ACTIVE
; 4: IEN<1000 & INACTIVE
; 5: IEN in local ns & INACTIVE
; 6: IEN in remote ns & INACTIVE
N I,PXVIEN,PXVORD,PXVST,PXINST,PXVSTIEN,PXVRAY,PXVLAST,PXVSTOP
N PXVREF,USE
;initialize precedence order array
F I=1:1:6 S PXVRAY(I,0)=0 ;set o node
;get site local number space
S PXINST=$$SITE^VASITE,PXINST=$P(PXINST,U,3) ;IA #10112
;process all existing records with same CVX code
F PXVIEN=0:0 S PXVIEN=$O(^AUTTIMM("C",CVX,PXVIEN)) Q:PXVIEN="" D
. S PXVST=$P(^AUTTIMM(PXVIEN,0),U,7)
. S PXVORD=""
. I PXVIEN<1000 S PXVORD=$S(PXVST="":1,1:4)
. I PXVIEN>(PXINST*1000),PXVIEN<(PXINST+1*1000) S PXVORD=$S(PXVST="":2,1:5)
. I $G(PXVORD)="" S PXVORD=$S(PXVST="":3,1:6)
. S PXVRAY(PXVORD,PXVIEN)="",PXVRAY(PXVORD,0)=PXVRAY(PXVORD,0)+1
;identify national entry
F PXVORD=1:1:6 D
. S PXVIEN=$O(PXVRAY(PXVORD,0)) Q:PXVIEN=""
. I $G(PXVSTIEN),(PXVIEN'=PXVSTIEN) D LOCAL(PXVIEN) Q ;rename losers
. I PXVRAY(PXVORD,0)=1 S PXVSTIEN=PXVIEN Q
. ;resolve ties
. I PXVRAY(PXVORD,0)>1 D
. . S USE=-1
. . S PXVSTOP="9000010.11,""IP"","_PXVIEN_","
. . F PXVIEN=0:0 S PXVIEN=$O(PXVRAY(PXVORD,PXVIEN)) Q:PXVIEN="" D
. . . S PXVREF="^PXRMINDX(9000010.11,""IP"","_PXVIEN_")"
. . . F I(PXVIEN)=0:1 S PXVREF=$Q(@PXVREF) Q:PXVREF'[PXVSTOP
. . . I $G(I(PXVIEN))>USE S PXVSTIEN=PXVIEN,USE=I(PXVIEN)
. . F IEN=0:0 S IEN=$O(I(IEN)) Q:IEN="" D
. . . Q:IEN=PXVSTIEN
. . . D LOCAL(IEN)
Q PXVSTIEN
;
STANDARD(PXVZ) ;set up standard record
;;ien of new entries =1000+CVX code
;;IEN/O^CVX^NAME^FULLNAME^COMB^STATUS^VIS^^CPT^^ACRONYM^PRODUCTNAME
N PXV,PXVIEN,PXVERR,PXVT,PXVNM,PXVWP,PXVS
S XUMF=1
S (PXVIEN(1),PXV)=+$P(PXVZ,U)
S PXVC=$P(PXVZ,U,2) ;CVX code
I $L(PXVC)=1 S PXVC="0"_PXVC ;append zero
;status
S PXVS=$P(PXVZ,U,6),PXVS=$S(PXVS["Active":"@",1:PXVS)
;add new one
I '+$P(PXVZ,U) D
. S PXVIEN(1)=1000+($P(PXVZ,U,2)),PXV="+1"
;avoid duplicate name errors
S PXVNM=$P($G(^AUTTIMM(+$P(PXVZ,U),0)),U)
I $$UP^XLFSTR($P(PXVZ,U,3))'=$$UP^XLFSTR(PXVNM) D
. S PXVT(9999999.14,PXV_",",.01)=$$UP^XLFSTR($P(PXVZ,U,3)) ;NAME
S PXVT(9999999.14,PXV_",",.07)=PXVS ;INACTIVE FLAG
S PXVT(9999999.14,PXV_",",.03)=PXVC ;CVX CODE
S PXVT(9999999.14,PXV_",",100)="NATIONAL" ;CLASS
S PXVT(9999999.14,PXV_",",.2)=$P(PXVZ,U,5) ;COMBO
S PXVT(9999999.14,PXV_",",8802)=$P(PXVZ,U,11) ;ACRONYM
S PXVT(9999999.14,PXV_",",8803)="Y" ;SELECTABLE
D UPDATE^DIE("E","PXVT","PXVIEN","PXVERR")
I $D(PXVERR) D ERROR(.PXVERR) Q 1
;CDC FULL VACCINE NAME
S PXVWP(1)=$P(PXVZ,U,4)
S PXVWP(1)=$$UP^XLFSTR($E(PXVWP(1),1))_$E(PXVWP(1),2,$L(PXVWP(1)))
D WP^DIE(9999999.14,PXVIEN(1)_",",2,"K","PXVWP","PXVERR")
I $D(PXVERR) D ERROR(.PXVERR) Q 1
;VACCINE INFORMATION STATEMENT
;CDC PRODUCT NAME
;CODING SYSTEM->CODE
D MANY(PXVIEN(1),.PXVZ)
Q $G(PXVIEN(1))_$S($D(PXVERR):1,1:0)
;
MANY(IEN,PXVZ) ;populates multiples
N PXVL,PXVCOL,PXVITEM,I,PXVT,PXVERR,PXVLL,PXVREC
;VIS
S PXVL=1,PXVCOL=$$UP^XLFSTR($P(PXVZ,U,7))
;muliple VIS with same name
F I=1:1 S PXVITEM=$P(PXVCOL,"|",I) Q:PXVITEM="" D
. F PXVREC=0:0 S PXVREC=$O(^AUTTIVIS("B",PXVITEM,PXVREC)) Q:PXVREC="" D
. . S PXVT(9999999.144,"?+"_PXVL_","_IEN_",",.01)=PXVREC
. . S PXVL=PXVL+1
;CDC PRODUCT NAMES
S PXVCOL=$$UP^XLFSTR($P(PXVZ,U,12))
F I=1:1 S PXVITEM=$P(PXVCOL,"|",I) Q:PXVITEM="" D
. S PXVT(9999999.145,"?+"_PXVL_","_IEN_",",.01)=PXVITEM
. S PXVL=PXVL+1
;CODING SYSTEM
S PXVCOL="CPT"
S PXVT(9999999.143,"?+"_PXVL_","_IEN_",",.01)=PXVCOL
;CPT CODES
S PXVLL=PXVL,PXVL=PXVL+1,PXVCOL=$P(PXVZ,U,9)
F I=1:1 S PXVITEM=$P(PXVCOL,"|",I) Q:PXVITEM="" D
. S PXVT(9999999.1431,"?+"_PXVL_",?+"_PXVLL_","_IEN_",",.01)=PXVITEM
. S PXVL=PXVL+1
D UPDATE^DIE(,"PXVT",,"PXVERR")
I $D(PXVERR) D ERROR(.PXVERR)
Q
;
REMAIN ;
;loop through file entries with no CVX code
N PXVIEN,PXVZ
S PXVIEN=0 F S PXVIEN=$O(^AUTTIMM(PXVIEN)) Q:PXVIEN'>0 D
. S PXVZ=$G(^AUTTIMM(+PXVIEN,0))
. Q:$P($G(^AUTTIMM(PXVIEN,100)),U)="N"
. D LOCAL(PXVIEN,PXVZ)
Q
;
LOCAL(PXVIEN,PXVZ) ;
N PXVT,PXVERR
;updates LOCAL record
I '$D(PXVZ) S PXVZ=$G(^AUTTIMM(PXVIEN,0))
I $P(PXVZ,U)'["(HISTORICAL)" S PXVT(9999999.14,PXVIEN_",",.01)=$P(PXVZ,U)_" (HISTORICAL)"
S PXVT(9999999.14,PXVIEN_",",.07)="INACTIVE"
S PXVT(9999999.14,PXVIEN_",",100)="LOCAL"
S PXVT(9999999.14,PXVIEN_",",8803)="N"
D UPDATE^DIE("E","PXVT",,"PXVERR")
I $D(PXVERR) D ERROR(.PXVERR)
Q
;
ERROR(PXVERR) ;
I '$D(^XTMP("PXVERR",0)) S ^XTMP("PXVERR",0)=$$FMADD^XLFDT(DT,10)_"^"_DT
S ERRCNT=$S('$D(ERRCNT):1,1:ERRCNT+1)
S $P(^XTMP("PXVERR",0),U,3)=ERRCNT
M ^XTMP("PXVERR",ERRCNT)=PXVERR
Q
;
MAIL ;
N PXVTXT,XMSUB,XMTEXT,PXVTXT,XMY,PXVOK,DIFROM
S PXVOK=$G(^XTMP("PXVERR",0))>0
S XMSUB="The IMMUNIZATION file update "
S XMSUB=XMSUB_$S(PXVOK:"FAILED",1:"was SUCCESSFUL")
S XMTEXT="PXVTXT("
I PXVOK D
. S PXVTXT(1)="Errors occurred during the update of the IMMUNIZATION file."
. S PXVTXT(2)="Details of the errors are stored in ^XTMP(""PXVERR"") for the next 10 days."
. S PXVTXT(3)="Please contact Product Support for assistance."
I 'PXVOK D
. S PXVTXT(1)="The IMMUNIZATION file has been successfully updated."
S XMY(DUZ)=""
D ^XMD
Q
;
DATA ;deletes data and copies from IMMUNIZATION
N J,DA,DIK
S XUMF=1
I '$D(^XTMP("PXVIMM")) W !,"RESTORE FAILED>>GLOBAL DOES NOT EXIST" Q
F J=0:0 S J=$O(^AUTTIMM(J)) Q:J'>0 D
. S DA=J,DIK="^AUTTIMM(" D ^DIK
S J=-1 F S J=$O(^XTMP("PXVIMM","PXV",J)) Q:J="" D
. M ^AUTTIMM(J)=^XTMP("PXVIMM","PXV",J)
;M ^AUTTIMM=^XTMP("PXVIMM","PXV")
Q
REINDX ; re-indexes "B" xref for #.01 and #8801
N DIK
K ^AUTTIMM("B")
S DIK="^AUTTIMM(",DIK(1)=".01^B" D ENALL^DIK
S DIK="^AUTTIMM(",DIK(1)="8801^B" D ENALL^DIK
Q
IMMUNIZ ;
N DIC,DIE,DA,DR,Y,XUMF
S XUMF=1
F PXV=0:0 S DIC="^AUTTIMM(",DIC(0)="AEQLN" D ^DIC Q:Y<0 D
. S DIE="^AUTTIMM(",DR=".03;.07;.2;2;3;4;5;100;8802;8803",DA=+Y D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXVP201 8957 printed Apr 09, 2024@21:33:51 Page 2
PXVP201 ;BPIOFO/CLR - Environment routines ; 9/29/14 10:59am
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**201**;Aug 12, 1996;Build 41
+2 ;
+3 QUIT
PRETRAN ;Load tables
+1 IF $GET(DUZ("AG"))'="V"
QUIT
+2 MERGE @XPDGREF@("PXVMAP")=^XTMP("PXVMAP")
+3 MERGE @XPDGREF@("PXVCVX")=^XTMP("PXVCVX")
+4 QUIT
+5 ;
PRE ;
+1 NEW DA,DIK,IEN
+2 IF $GET(DUZ("AG"))'="V"
QUIT
+3 ;check that site has no IMMUNIZATION IENs between 1000 and 2000
+4 IF '$DATA(^AUTTIVIS)
IF ($ORDER(^AUTTIMM(1000))<2000)
WRITE !,"Invalid IEN in the IMMUNIZATION file - INSTALLATION ABORTED"
SET XPDABORT=1
QUIT
+5 ;delete data definitions in V IMMUNIZATION
+6 FOR DA=.08,.09,.1,.11,.12,.13,.14,.15
SET DIK="^DD(9000010.11,"
SET DA(1)=9000010.11
DO ^DIK
+7 ;delete IMM MANUFACTURER
+8 IF $DATA(^AUTTIMAN)
SET IEN=0
SET DIK="^AUTTIMAN("
Begin DoDot:1
+9 FOR
SET IEN=$ORDER(^AUTTIMAN(IEN))
if IEN'>0
QUIT
Begin DoDot:2
+10 SET DA=IEN
DO ^DIK
End DoDot:2
End DoDot:1
+11 ;delete VACCINE INFORMATION STATEMENT
+12 IF $DATA(^AUTTIVIS)
SET IEN=0
SET DIK="^AUTTIVIS("
Begin DoDot:1
+13 FOR
SET IEN=$ORDER(^AUTTIVIS(IEN))
if IEN'>0
QUIT
Begin DoDot:2
+14 SET DA=IEN
DO ^DIK
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
POST ;Post installation
+1 ;do not install in non-VA environments
IF $GET(DUZ("AG"))'="V"
QUIT
+2 NEW ERRCNT,PXVCPDT,XUMF
+3 KILL ^XTMP("PXVMAP"),^XTMP("PXVCVX"),^XTMP("PXVERR")
+4 MERGE ^XTMP("PXVMAP")=@XPDGREF@("PXVMAP")
+5 MERGE ^XTMP("PXVCVX")=@XPDGREF@("PXVCVX")
+6 IF '$DATA(^XTMP("PXVMAP"))!('$DATA(^XTMP("PXVCVX")))
WRITE !,"Mapping table not loaded - INSTALLATION ABORTED"
SET XPDQUIT=2
QUIT
+7 IF '$DATA(^XTMP("PXVIMM"))
MERGE ^XTMP("PXVIMM","PXV")=^AUTTIMM
+8 SET PXVCPDT=$$FMADD^XLFDT(DT,10)
+9 ;set purge ddt/creation dt
SET ^XTMP("PXVMAP",0)=PXVCPDT_"^"_DT
+10 SET ^XTMP("PXVCVX",0)=PXVCPDT_"^"_DT
+11 SET PXVCPDT=$$FMADD^XLFDT(DT,90)
+12 SET ^XTMP("PXVIMM",0)=PXVCPDT_"^"_DT
+13 ;restores backup
DO DATA
+14 ;re-indexex "B" crossref
DO REINDX
+15 ;maps local entries to CVX code using data in ^XTMP("PXVMAP")
DO MAP
+16 ;Selects/updates standard entry for each CVX code
+17 ;using data in ^XTMP("PXVCVX")
+18 DO SELECT
+19 ;updates non-standard entries
DO REMAIN
+20 ;sends email to installer
DO MAIL
+21 ;move data in V IMMUNIZATION
DO MVDIAGS^PXVPST01
+22 QUIT
+23 ;
MAP ;map local names to CVX codes
+1 SET XUMF=1
+2 NEW PXVZ,PXVIEN,PXVERR,PXVC,I,PXVT
+3 FOR I=0:0
SET I=$ORDER(^XTMP("PXVMAP",I))
if I'>0
QUIT
Begin DoDot:1
+4 SET PXVZ=$GET(^XTMP("PXVMAP",I,0))
+5 FOR PXVIEN=0:0
SET PXVIEN=$ORDER(^AUTTIMM("B",$PIECE(PXVZ,U),PXVIEN))
if PXVIEN=""
QUIT
Begin DoDot:2
+6 SET PXVC=$SELECT($LENGTH($PIECE(PXVZ,U,2))=1:"0"_($PIECE(PXVZ,U,2)),1:$PIECE(PXVZ,U,2))
+7 SET PXVT(9999999.14,+PXVIEN_",",.03)=PXVC
+8 DO UPDATE^DIE(,"PXVT",,"PXVERR")
+9 IF $DATA(PXVERR)
DO ERROR(.PXVERR)
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
SELECT ;Select standard in local file entries with CVX code
+1 NEW I,PXVSTIEN,PXVC,PXVZ,PXVOUT
+2 FOR I=0:0
SET I=$ORDER(^XTMP("PXVCVX",I))
if I=""
QUIT
Begin DoDot:1
+3 SET PXVZ=$GET(^XTMP("PXVCVX",I,0))
+4 ;handles one overflow line
+5 SET PXVZ=PXVZ_$GET(^XTMP("PXVCVX",I,"OVF",1))
+6 SET PXVC=$PIECE(PXVZ,U)
SET PXVC=$SELECT($LENGTH(PXVC)=1:"0"_PXVC,1:PXVC)
+7 IF '$DATA(^AUTTIMM("C",PXVC))
Begin DoDot:2
+8 SET PXVZ="0^"_PXVZ
+9 SET PXVOUT=$$STANDARD(PXVZ)
End DoDot:2
QUIT
+10 ;get ien of standard entry
+11 SET PXVSTIEN=$$ORDER(PXVC)
+12 SET PXVZ=PXVSTIEN_"^"_PXVZ
+13 SET PXVOUT=$$STANDARD(PXVZ)
End DoDot:1
+14 QUIT
+15 ;
ORDER(CVX) ;determines precedence order for record
+1 ; 1: IEN<1000 & ACTIVE
+2 ; 2: IEN in local ns & ACTIVE
+3 ; 3: IEN in remote ns & ACTIVE
+4 ; 4: IEN<1000 & INACTIVE
+5 ; 5: IEN in local ns & INACTIVE
+6 ; 6: IEN in remote ns & INACTIVE
+7 NEW I,PXVIEN,PXVORD,PXVST,PXINST,PXVSTIEN,PXVRAY,PXVLAST,PXVSTOP
+8 NEW PXVREF,USE
+9 ;initialize precedence order array
+10 ;set o node
FOR I=1:1:6
SET PXVRAY(I,0)=0
+11 ;get site local number space
+12 ;IA #10112
SET PXINST=$$SITE^VASITE
SET PXINST=$PIECE(PXINST,U,3)
+13 ;process all existing records with same CVX code
+14 FOR PXVIEN=0:0
SET PXVIEN=$ORDER(^AUTTIMM("C",CVX,PXVIEN))
if PXVIEN=""
QUIT
Begin DoDot:1
+15 SET PXVST=$PIECE(^AUTTIMM(PXVIEN,0),U,7)
+16 SET PXVORD=""
+17 IF PXVIEN<1000
SET PXVORD=$SELECT(PXVST="":1,1:4)
+18 IF PXVIEN>(PXINST*1000)
IF PXVIEN<(PXINST+1*1000)
SET PXVORD=$SELECT(PXVST="":2,1:5)
+19 IF $GET(PXVORD)=""
SET PXVORD=$SELECT(PXVST="":3,1:6)
+20 SET PXVRAY(PXVORD,PXVIEN)=""
SET PXVRAY(PXVORD,0)=PXVRAY(PXVORD,0)+1
End DoDot:1
+21 ;identify national entry
+22 FOR PXVORD=1:1:6
Begin DoDot:1
+23 SET PXVIEN=$ORDER(PXVRAY(PXVORD,0))
if PXVIEN=""
QUIT
+24 ;rename losers
IF $GET(PXVSTIEN)
IF (PXVIEN'=PXVSTIEN)
DO LOCAL(PXVIEN)
QUIT
+25 IF PXVRAY(PXVORD,0)=1
SET PXVSTIEN=PXVIEN
QUIT
+26 ;resolve ties
+27 IF PXVRAY(PXVORD,0)>1
Begin DoDot:2
+28 SET USE=-1
+29 SET PXVSTOP="9000010.11,""IP"","_PXVIEN_","
+30 FOR PXVIEN=0:0
SET PXVIEN=$ORDER(PXVRAY(PXVORD,PXVIEN))
if PXVIEN=""
QUIT
Begin DoDot:3
+31 SET PXVREF="^PXRMINDX(9000010.11,""IP"","_PXVIEN_")"
+32 FOR I(PXVIEN)=0:1
SET PXVREF=$QUERY(@PXVREF)
if PXVREF'[PXVSTOP
QUIT
+33 IF $GET(I(PXVIEN))>USE
SET PXVSTIEN=PXVIEN
SET USE=I(PXVIEN)
End DoDot:3
+34 FOR IEN=0:0
SET IEN=$ORDER(I(IEN))
if IEN=""
QUIT
Begin DoDot:3
+35 if IEN=PXVSTIEN
QUIT
+36 DO LOCAL(IEN)
End DoDot:3
End DoDot:2
End DoDot:1
+37 QUIT PXVSTIEN
+38 ;
STANDARD(PXVZ) ;set up standard record
+1 ;;ien of new entries =1000+CVX code
+2 ;;IEN/O^CVX^NAME^FULLNAME^COMB^STATUS^VIS^^CPT^^ACRONYM^PRODUCTNAME
+3 NEW PXV,PXVIEN,PXVERR,PXVT,PXVNM,PXVWP,PXVS
+4 SET XUMF=1
+5 SET (PXVIEN(1),PXV)=+$PIECE(PXVZ,U)
+6 ;CVX code
SET PXVC=$PIECE(PXVZ,U,2)
+7 ;append zero
IF $LENGTH(PXVC)=1
SET PXVC="0"_PXVC
+8 ;status
+9 SET PXVS=$PIECE(PXVZ,U,6)
SET PXVS=$SELECT(PXVS["Active":"@",1:PXVS)
+10 ;add new one
+11 IF '+$PIECE(PXVZ,U)
Begin DoDot:1
+12 SET PXVIEN(1)=1000+($PIECE(PXVZ,U,2))
SET PXV="+1"
End DoDot:1
+13 ;avoid duplicate name errors
+14 SET PXVNM=$PIECE($GET(^AUTTIMM(+$PIECE(PXVZ,U),0)),U)
+15 IF $$UP^XLFSTR($PIECE(PXVZ,U,3))'=$$UP^XLFSTR(PXVNM)
Begin DoDot:1
+16 ;NAME
SET PXVT(9999999.14,PXV_",",.01)=$$UP^XLFSTR($PIECE(PXVZ,U,3))
End DoDot:1
+17 ;INACTIVE FLAG
SET PXVT(9999999.14,PXV_",",.07)=PXVS
+18 ;CVX CODE
SET PXVT(9999999.14,PXV_",",.03)=PXVC
+19 ;CLASS
SET PXVT(9999999.14,PXV_",",100)="NATIONAL"
+20 ;COMBO
SET PXVT(9999999.14,PXV_",",.2)=$PIECE(PXVZ,U,5)
+21 ;ACRONYM
SET PXVT(9999999.14,PXV_",",8802)=$PIECE(PXVZ,U,11)
+22 ;SELECTABLE
SET PXVT(9999999.14,PXV_",",8803)="Y"
+23 DO UPDATE^DIE("E","PXVT","PXVIEN","PXVERR")
+24 IF $DATA(PXVERR)
DO ERROR(.PXVERR)
QUIT 1
+25 ;CDC FULL VACCINE NAME
+26 SET PXVWP(1)=$PIECE(PXVZ,U,4)
+27 SET PXVWP(1)=$$UP^XLFSTR($EXTRACT(PXVWP(1),1))_$EXTRACT(PXVWP(1),2,$LENGTH(PXVWP(1)))
+28 DO WP^DIE(9999999.14,PXVIEN(1)_",",2,"K","PXVWP","PXVERR")
+29 IF $DATA(PXVERR)
DO ERROR(.PXVERR)
QUIT 1
+30 ;VACCINE INFORMATION STATEMENT
+31 ;CDC PRODUCT NAME
+32 ;CODING SYSTEM->CODE
+33 DO MANY(PXVIEN(1),.PXVZ)
+34 QUIT $GET(PXVIEN(1))_$SELECT($DATA(PXVERR):1,1:0)
+35 ;
MANY(IEN,PXVZ) ;populates multiples
+1 NEW PXVL,PXVCOL,PXVITEM,I,PXVT,PXVERR,PXVLL,PXVREC
+2 ;VIS
+3 SET PXVL=1
SET PXVCOL=$$UP^XLFSTR($PIECE(PXVZ,U,7))
+4 ;muliple VIS with same name
+5 FOR I=1:1
SET PXVITEM=$PIECE(PXVCOL,"|",I)
if PXVITEM=""
QUIT
Begin DoDot:1
+6 FOR PXVREC=0:0
SET PXVREC=$ORDER(^AUTTIVIS("B",PXVITEM,PXVREC))
if PXVREC=""
QUIT
Begin DoDot:2
+7 SET PXVT(9999999.144,"?+"_PXVL_","_IEN_",",.01)=PXVREC
+8 SET PXVL=PXVL+1
End DoDot:2
End DoDot:1
+9 ;CDC PRODUCT NAMES
+10 SET PXVCOL=$$UP^XLFSTR($PIECE(PXVZ,U,12))
+11 FOR I=1:1
SET PXVITEM=$PIECE(PXVCOL,"|",I)
if PXVITEM=""
QUIT
Begin DoDot:1
+12 SET PXVT(9999999.145,"?+"_PXVL_","_IEN_",",.01)=PXVITEM
+13 SET PXVL=PXVL+1
End DoDot:1
+14 ;CODING SYSTEM
+15 SET PXVCOL="CPT"
+16 SET PXVT(9999999.143,"?+"_PXVL_","_IEN_",",.01)=PXVCOL
+17 ;CPT CODES
+18 SET PXVLL=PXVL
SET PXVL=PXVL+1
SET PXVCOL=$PIECE(PXVZ,U,9)
+19 FOR I=1:1
SET PXVITEM=$PIECE(PXVCOL,"|",I)
if PXVITEM=""
QUIT
Begin DoDot:1
+20 SET PXVT(9999999.1431,"?+"_PXVL_",?+"_PXVLL_","_IEN_",",.01)=PXVITEM
+21 SET PXVL=PXVL+1
End DoDot:1
+22 DO UPDATE^DIE(,"PXVT",,"PXVERR")
+23 IF $DATA(PXVERR)
DO ERROR(.PXVERR)
+24 QUIT
+25 ;
REMAIN ;
+1 ;loop through file entries with no CVX code
+2 NEW PXVIEN,PXVZ
+3 SET PXVIEN=0
FOR
SET PXVIEN=$ORDER(^AUTTIMM(PXVIEN))
if PXVIEN'>0
QUIT
Begin DoDot:1
+4 SET PXVZ=$GET(^AUTTIMM(+PXVIEN,0))
+5 if $PIECE($GET(^AUTTIMM(PXVIEN,100)),U)="N"
QUIT
+6 DO LOCAL(PXVIEN,PXVZ)
End DoDot:1
+7 QUIT
+8 ;
LOCAL(PXVIEN,PXVZ) ;
+1 NEW PXVT,PXVERR
+2 ;updates LOCAL record
+3 IF '$DATA(PXVZ)
SET PXVZ=$GET(^AUTTIMM(PXVIEN,0))
+4 IF $PIECE(PXVZ,U)'["(HISTORICAL)"
SET PXVT(9999999.14,PXVIEN_",",.01)=$PIECE(PXVZ,U)_" (HISTORICAL)"
+5 SET PXVT(9999999.14,PXVIEN_",",.07)="INACTIVE"
+6 SET PXVT(9999999.14,PXVIEN_",",100)="LOCAL"
+7 SET PXVT(9999999.14,PXVIEN_",",8803)="N"
+8 DO UPDATE^DIE("E","PXVT",,"PXVERR")
+9 IF $DATA(PXVERR)
DO ERROR(.PXVERR)
+10 QUIT
+11 ;
ERROR(PXVERR) ;
+1 IF '$DATA(^XTMP("PXVERR",0))
SET ^XTMP("PXVERR",0)=$$FMADD^XLFDT(DT,10)_"^"_DT
+2 SET ERRCNT=$SELECT('$DATA(ERRCNT):1,1:ERRCNT+1)
+3 SET $PIECE(^XTMP("PXVERR",0),U,3)=ERRCNT
+4 MERGE ^XTMP("PXVERR",ERRCNT)=PXVERR
+5 QUIT
+6 ;
MAIL ;
+1 NEW PXVTXT,XMSUB,XMTEXT,PXVTXT,XMY,PXVOK,DIFROM
+2 SET PXVOK=$GET(^XTMP("PXVERR",0))>0
+3 SET XMSUB="The IMMUNIZATION file update "
+4 SET XMSUB=XMSUB_$SELECT(PXVOK:"FAILED",1:"was SUCCESSFUL")
+5 SET XMTEXT="PXVTXT("
+6 IF PXVOK
Begin DoDot:1
+7 SET PXVTXT(1)="Errors occurred during the update of the IMMUNIZATION file."
+8 SET PXVTXT(2)="Details of the errors are stored in ^XTMP(""PXVERR"") for the next 10 days."
+9 SET PXVTXT(3)="Please contact Product Support for assistance."
End DoDot:1
+10 IF 'PXVOK
Begin DoDot:1
+11 SET PXVTXT(1)="The IMMUNIZATION file has been successfully updated."
End DoDot:1
+12 SET XMY(DUZ)=""
+13 DO ^XMD
+14 QUIT
+15 ;
DATA ;deletes data and copies from IMMUNIZATION
+1 NEW J,DA,DIK
+2 SET XUMF=1
+3 IF '$DATA(^XTMP("PXVIMM"))
WRITE !,"RESTORE FAILED>>GLOBAL DOES NOT EXIST"
QUIT
+4 FOR J=0:0
SET J=$ORDER(^AUTTIMM(J))
if J'>0
QUIT
Begin DoDot:1
+5 SET DA=J
SET DIK="^AUTTIMM("
DO ^DIK
End DoDot:1
+6 SET J=-1
FOR
SET J=$ORDER(^XTMP("PXVIMM","PXV",J))
if J=""
QUIT
Begin DoDot:1
+7 MERGE ^AUTTIMM(J)=^XTMP("PXVIMM","PXV",J)
End DoDot:1
+8 ;M ^AUTTIMM=^XTMP("PXVIMM","PXV")
+9 QUIT
REINDX ; re-indexes "B" xref for #.01 and #8801
+1 NEW DIK
+2 KILL ^AUTTIMM("B")
+3 SET DIK="^AUTTIMM("
SET DIK(1)=".01^B"
DO ENALL^DIK
+4 SET DIK="^AUTTIMM("
SET DIK(1)="8801^B"
DO ENALL^DIK
+5 QUIT
IMMUNIZ ;
+1 NEW DIC,DIE,DA,DR,Y,XUMF
+2 SET XUMF=1
+3 FOR PXV=0:0
SET DIC="^AUTTIMM("
SET DIC(0)="AEQLN"
DO ^DIC
if Y<0
QUIT
Begin DoDot:1
+4 SET DIE="^AUTTIMM("
SET DR=".03;.07;.2;2;3;4;5;100;8802;8803"
SET DA=+Y
DO ^DIE
End DoDot:1
+5 QUIT
