- 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 Feb 18, 2025@23:58:05 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