PXVP206 ;BPOIFO/CLR - POST INSTALL ;01/14/15 12:38pm
;;1.0;PCE PATIENT CARE ENCOUNTER;**206**;Aug 12, 1996;Build 50
;
; This routine uses the following IAs:
; #4639 - ^HDISVCMR calls (supported)
; #4651 - ^HDISVF09 calls (supported)
; #4640 - ^HDISVF01 calls (supported)
;
Q
;
PRETRAN ;Load spreadsheet
M @XPDGREF@("PXVSKX")=^XTMP("PXVSKX")
Q
;
PRE ;
N PXVI,PXVNM,I,PXVC
;delete SHORT NAME identifier
I $D(^DD(9999999.14,0,"ID",.02)) K ^DD(9999999.14,0,"ID",.02)
I $$DUP() D Q
. D BMES^XPDUTL("DUPLICATE Names were found in the SKIN TEST file - INSTALLATION ABORTED")
. S XPDABORT=1
D DELETE(920) ;kills file
Q
;
POST ;Post installation
;standardize SKIN Test file
;
N ERRCNT,PXVCPDT,XUMF,PXVGL,PXVF
S XUMF=1
K ^XTMP("PXVSKX"),^XTMP("PXVERR")
M ^XTMP("PXVSKX")=@XPDGREF@("PXVSKX")
I '$D(^XTMP("PXVSKB")) M ^XTMP("PXVSKB",9999999.28)=^AUTTSK
S PXVCPDT=$$FMADD^XLFDT(DT,90)
S ^XTMP("PXVSKX",0)=PXVCPDT_"^"_DT ;set purge ddt/creation dt
S PXVCPDT=$$FMADD^XLFDT(DT,60)
S ^XTMP("PXVSKB",0)=PXVCPDT_"^"_DT
;backup files populated in PX*1*201
I '$D(^XTMP("PXVBKUP")) D
. F PXVF=920.1,920.2,920.3,9999999.04,9999999.14,920.4,920.5 D
. . S PXVGL=$$ROOT^DILFD(PXVF,"",1) Q:PXVGL=""
. . M ^XTMP("PXVBKUP",PXVF)=@PXVGL
S ^XTMP("PXVBKUP",0)=PXVCPDT_"^"_DT ;90 days
D DATA ;restores original SKIN TEST file
D SELECT ;standardizes entries in skin test file
D REMAIN ;inactivates non-standard entries
D SHORTNM ;fixes spelling error
D MAIL
I $D(^XTMP("PXVERR")) D Q
. D BMES^XPDUTL("Master File Server Seeding was aborted because of errors in the SKIN TEST file conversion!!")
D CLEAN ;deletes MAX# IN SERIES values
D HDIS ;seeds if no errors
Q
;
SELECT ;Select standard in local file entries
N I,PXVIEN,PXVNM,PXVZ,PXVOUT,PXVERR,PXVNAT
F I=0:0 S I=$O(^XTMP("PXVSKX",I)) Q:I="" D
. S PXVZ=$G(^XTMP("PXVSKX",I,0))
. S PXVNM=$P(PXVZ,U,2)
. S PXVIEN=$$IEN(PXVNM)
. I $P(PXVZ,U)="" D Q
. . Q:'+PXVIEN ;quit if not in file
. . D LOCAL(PXVIEN)
. S PXVZ=PXVIEN_"^"_I_"~"_PXVZ
. S PXVOUT=$$STANDARD(PXVZ)
Q
;
STANDARD(PXVZ) ;set up standard record
; .01 NAME
; .02 CODE
; .03 INACTIVE FLAG
; .11 CPT CODE
; 3 CODING SYSTEM (multiple)
; 1201 PRINT NAME
; 8801 MNEMONIC
;IEN/0^ROW #~CLASS^NAME^PRINT NAME^STATUS^CPT^MAP NAME
N PXV,PXVT,PXVNM,PXVRNM,PXVMAPN,PXVPRT,PXVIEN,PXVERR
Q:PXVZ="" 1
Q:$D(PXVNAT($P(PXVZ,U,4))) 1 ;duplicate National record
I $P(PXVZ,U,7)'="" Q:$D(^AUTTSK("B",$P(PXVZ,U,7))) 1 ;quit if record exists with map name
S XUMF=1
S (PXV,PXVIEN(1))=+$P(PXVZ,U)
I '+$P(PXVZ,U) D
. S PXVIEN(1)=100+(+$P($P(PXVZ,U,2),"~")),PXV="+1" ;get IEN
S PXVRNM=$S(PXV="+1":"",1:$P($G(^AUTTSK(+$P(PXVZ,U),0)),U)) ;Record Name
S PXVNM=$$UP^XLFSTR($P(PXVZ,U,3)) ;Name
S PXVPRT=$P(PXVZ,U,4) ;Print Name
S PXVMAPN=$P(PXVZ,U,7) ;Map Name
I PXV="+1",$D(^AUTTSK("B",PXVPRT)) D
. ;if record already exists with print name, use that record
. S (PXV,PXVIEN(1))=$O(^AUTTSK("B",PXVPRT,""))
. S PXVRNM=PXVPRT
I $$UP^XLFSTR(PXVRNM)'=PXVPRT D
. S PXVT(9999999.28,PXV_",",.01)=PXVPRT ;REPLACE NAME W/PRINT NAME
S PXVT(9999999.28,PXV_",",1201)=$S(PXVMAPN]"":PXVMAPN,1:PXVNM)
I PXV'="+1",(+$P($G(^AUTTSK(PXV,0)),U,3)) S $P(^AUTTSK(PXV,0),U,3)="" ;uneditable prevents FM edit
S PXVT(9999999.28,PXV_",",100)="NATIONAL"
S PXVNAT(PXVPRT)=""
D UPDATE^DIE("E","PXVT","PXVIEN","PXVERR")
I $D(PXVERR) D ERROR(.PXVERR),BMES(PXVIEN(1)) Q 1
;CODING SYSTEM->CODE
I $P(PXVZ,U,6) D MANY(PXVIEN(1),.PXVZ)
Q $G(PXV)_U_$S($D(PXVERR):1,1:0)
;
MANY(IEN,PXVZ) ;populates Coding Multiple
N PXVL,PXVCOL,PXVITEM,I,PXVT,PXVERR,PXVLL,PXVREC
;CODING SYSTEM
S PXVCOL="CPT",PXVL=1
S PXVT(9999999.283,"?+"_PXVL_","_IEN_",",.01)=PXVCOL
;CPT CODES
S PXVLL=PXVL,PXVL=PXVL+1,PXVCOL=$P(PXVZ,U,6)
F I=1:1 S PXVITEM=$P(PXVCOL,"|",I) Q:PXVITEM="" D
. S PXVT(9999999.2831,"?+"_PXVL_",?+"_PXVLL_","_IEN_",",.01)=PXVITEM
. S PXVL=PXVL+1
D UPDATE^DIE(,"PXVT",,"PXVERR")
I $D(PXVERR) D ERROR(.PXVERR),BMES(IEN)
Q
;
REMAIN ;
;loop through file entries with no Class code
N PXVIEN,PXVZ
F PXVIEN=0:0 S PXVIEN=$O(^AUTTSK(PXVIEN)) Q:PXVIEN'>0 D
. S PXVZ=$G(^AUTTSK(+PXVIEN,0))
. I $P($G(^AUTTSK(PXVIEN,100)),U)="" D LOCAL(PXVIEN)
Q
;
LOCAL(PXVIEN) ;
N PXVT,PXVERR
I $P($G(^AUTTSK(+PXVIEN,0)),U,3)="" S PXVT(9999999.28,PXVIEN_",",.03)="INACTIVE"
S PXVT(9999999.28,PXVIEN_",",100)="LOCAL"
D UPDATE^DIE("E","PXVT",,"PXVERR")
I $D(PXVERR) D ERROR(.PXVERR),BMES(PXVIEN)
Q
;
DUP() ;
; Returns 0: No duplicates
; 1: Duplicate
N PXVARY,PXVFLG,PXV,PXVIEN
S PXVFLG=0,PXV=-1 F S PXV=$O(^AUTTSK("B",PXV)) Q:PXV=""!(PXVFLG) D
. F PXVIEN=0:0 S PXVIEN=$O(^AUTTSK("B",PXV,PXVIEN)) Q:PXVIEN="" D
. . I '$D(PXVARY($$UP^XLFSTR(PXV))) S PXVARY($$UP^XLFSTR(PXV))="" Q
. . S PXVFLG=1
Q PXVFLG
;
IEN(PXVNM) ;
;Returns 0: No match
; IEN: Matching IEN
N PXVI,PXVIEN
S PXVIEN="",PXVI=""
F PXVNM=PXVNM,$$LOW^XLFSTR(PXVNM),$$SENTENCE^XLFSTR(PXVNM),$$TITLE^XLFSTR(PXVNM) D
. F S PXVI=$O(^AUTTSK("B",PXVNM,PXVI)) Q:PXVI="" D
. . S PXVIEN=PXVI
Q +PXVIEN
;
ERROR(PXVERR) ;
I '$D(^XTMP("PXVERR",0)) S ^XTMP("PXVERR",0)=$$FMADD^XLFDT(DT,30)_"^"_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 SKIN TEST 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 SKIN TEST (#9999999.28) file."
. S PXVTXT(2)="Master File Server Seeding was aborted."
. S PXVTXT(3)="Details of the errors are stored in ^XTMP(""PXVERR"") for the next 30 days."
. S PXVTXT(4)="Please contact Product Support for assistance."
I 'PXVOK D
. S PXVTXT(1)="The SKIN TEST file has been successfully updated."
S XMY(DUZ)=""
D ^XMD
Q
;
DATA ;deletes data in the SKIN TEST file and restores from backup
N PXVI,DA,DIK
S XUMF=1
I '$D(^XTMP("PXVSKB")) D BMES^XPDUTL("SKIN TEST was not restored") Q
F PXVI=0:0 S PXVI=$O(^AUTTSK(PXVI)) Q:PXVI'>0 D
. S DA=PXVI,DIK="^AUTTSK(" D ^DIK
S PXVI=-1 F S PXVI=$O(^XTMP("PXVSKB",9999999.28,PXVI)) Q:PXVI="" D
. M ^AUTTSK(PXVI)=^XTMP("PXVSKB",9999999.28,PXVI)
Q
;
DELETE(PXVFN) ;
; Delete data in selected file
N PXVG,J,DIK,DA,XUMF
S PXVG=$$ROOT^DILFD(PXVFN,0,"GL")
S XUMF=1
F J=0:0 S J=$O(@(PXVG_J_")")) Q:J'>0 D
. S DA=J,DIK=PXVG D ^DIK
Q
;
BMES(IEN) ;
Q:IEN=""
D BMES^XPDUTL("Fileman error in SKIN TEST record # "_IEN)
Q
;
SHORTNM ;fix short name spelling
N PXVI,PXVT,PXVERR
S PXVI=$O(^AUTTIMM("B","VARICELLA","")) Q:PXVI="" D
. Q:'$D(^AUTTIMM("D","VARCELLA",PXVI))
. S PXVT(9999999.14,PXVI_",",.02)="VARICELLA"
. D UPDATE^DIE("E","PXVT")
Q
;
CLEAN ;deletes MAX#INSERIES
N PXV
F PXV=0:0 S PXV=$O(^AUTTIMM(PXV)) Q:PXV'>0 D
. Q:$P($G(^AUTTIMM(PXV,0)),U,5)=""
. I $D(^AUTTIMM(PXV,0)) S $P(^AUTTIMM(PXV,0),U,5)=""
Q
;
HDIS ; Call HDIS to begin the 'seeding' process
N DOMPTR,TMP
D SETSTAT^HDISVF01(920,,4) ;sets seeding status of 920 to 'AWAITING ERT UPDATE'
D ERTBULL ;sends bulletin to ERT
S TMP=$$GETIEN^HDISVF09("IMMUNIZATIONS",.DOMPTR)
D EN^HDISVCMR(DOMPTR,"")
Q
;
UPD ;
N DIC,DIE,DA,DR,Y,XUMF
S XUMF=1
F PXV=0:0 S DIC="^AUTTSK(",DIC(0)="AEQLN" D ^DIC Q:Y<0 D
. S DIE="^AUTTSK(",DR=".01;.03;3;100;1201;8801",DA=+Y D ^DIE
Q
;
ERTBULL ;
;sends bulletin to ERT that 920 is ready for full file update
N PXVTMP,HDISP,HDISFLAG,HDISTASK
S PXVTMP=$$SITE^VASITE()
S HDISP(1)=$P(PXVTMP,"^",2),HDISP(1)=HDISP(1)_" (#"_($P(PXVTMP,"^",3))_") with Domain/IP Address "_$G(^XMB("NETNAME")) ;facility name
S HDISP(2)="VACCINE INFORMATION STATEMENT (#920)"
S HDISP(3)=$$NOW^XLFDT N Y S Y=HDISP(3) D DD^%DT S HDISP(3)=Y ;date/time
S HDISP(4)=$$PROD^XUPROD(),HDISP(4)=$S(HDISP(4):"PRODUCTION",1:"TEST") ;system type
S HDISP(5)=$P(PXVTMP,"^",3) ;facility number
S HDISP(6)=920
S HDISFLAG("FROM")="HDIS Data Standardization Server"
D TASKBULL^XMXAPI(DUZ,"HDIS NOTIFY ERT",.HDISP,,,.HDISFLAG,.HDISTASK) ;
Q
;
RESTORE(PXVF) ;
N PXVGL,PXVI
I (PXVF'=920.1)&(PXVF'=920.2)&(PXVF'=920.3)&(PXVF'=920.4)&(PXVF'=920.5)&(PXVF'=9999999.04)&(PXVF'=9999999.14) D Q
. W !,"Only 920.1, 920.2, 920.3, 920.4, 920.5,9999999.04 and 9999999.14 can be restored using this API."
I '$D(^XTMP("PXVBKUP",PXVF)) W !,"Data backup has been purged. Restore is aborted." Q
D DELETE(PXVF)
S PXVGL=$$ROOT^DILFD(PXVF)
S PXVI=-1 F S PXVI=$O(^XTMP("PXVBKUP",PXVF,PXVI)) Q:PXVI="" D
. M @(PXVGL_""""_PXVI_""""_")")=^XTMP("PXVBKUP",PXVF,PXVI)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXVP206 8850 printed Apr 09, 2024@21:30:15 Page 2
PXVP206 ;BPOIFO/CLR - POST INSTALL ;01/14/15 12:38pm
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**206**;Aug 12, 1996;Build 50
+2 ;
+3 ; This routine uses the following IAs:
+4 ; #4639 - ^HDISVCMR calls (supported)
+5 ; #4651 - ^HDISVF09 calls (supported)
+6 ; #4640 - ^HDISVF01 calls (supported)
+7 ;
+8 QUIT
+9 ;
PRETRAN ;Load spreadsheet
+1 MERGE @XPDGREF@("PXVSKX")=^XTMP("PXVSKX")
+2 QUIT
+3 ;
PRE ;
+1 NEW PXVI,PXVNM,I,PXVC
+2 ;delete SHORT NAME identifier
+3 IF $DATA(^DD(9999999.14,0,"ID",.02))
KILL ^DD(9999999.14,0,"ID",.02)
+4 IF $$DUP()
Begin DoDot:1
+5 DO BMES^XPDUTL("DUPLICATE Names were found in the SKIN TEST file - INSTALLATION ABORTED")
+6 SET XPDABORT=1
End DoDot:1
QUIT
+7 ;kills file
DO DELETE(920)
+8 QUIT
+9 ;
POST ;Post installation
+1 ;standardize SKIN Test file
+2 ;
+3 NEW ERRCNT,PXVCPDT,XUMF,PXVGL,PXVF
+4 SET XUMF=1
+5 KILL ^XTMP("PXVSKX"),^XTMP("PXVERR")
+6 MERGE ^XTMP("PXVSKX")=@XPDGREF@("PXVSKX")
+7 IF '$DATA(^XTMP("PXVSKB"))
MERGE ^XTMP("PXVSKB",9999999.28)=^AUTTSK
+8 SET PXVCPDT=$$FMADD^XLFDT(DT,90)
+9 ;set purge ddt/creation dt
SET ^XTMP("PXVSKX",0)=PXVCPDT_"^"_DT
+10 SET PXVCPDT=$$FMADD^XLFDT(DT,60)
+11 SET ^XTMP("PXVSKB",0)=PXVCPDT_"^"_DT
+12 ;backup files populated in PX*1*201
+13 IF '$DATA(^XTMP("PXVBKUP"))
Begin DoDot:1
+14 FOR PXVF=920.1,920.2,920.3,9999999.04,9999999.14,920.4,920.5
Begin DoDot:2
+15 SET PXVGL=$$ROOT^DILFD(PXVF,"",1)
if PXVGL=""
QUIT
+16 MERGE ^XTMP("PXVBKUP",PXVF)=@PXVGL
End DoDot:2
End DoDot:1
+17 ;90 days
SET ^XTMP("PXVBKUP",0)=PXVCPDT_"^"_DT
+18 ;restores original SKIN TEST file
DO DATA
+19 ;standardizes entries in skin test file
DO SELECT
+20 ;inactivates non-standard entries
DO REMAIN
+21 ;fixes spelling error
DO SHORTNM
+22 DO MAIL
+23 IF $DATA(^XTMP("PXVERR"))
Begin DoDot:1
+24 DO BMES^XPDUTL("Master File Server Seeding was aborted because of errors in the SKIN TEST file conversion!!")
End DoDot:1
QUIT
+25 ;deletes MAX# IN SERIES values
DO CLEAN
+26 ;seeds if no errors
DO HDIS
+27 QUIT
+28 ;
SELECT ;Select standard in local file entries
+1 NEW I,PXVIEN,PXVNM,PXVZ,PXVOUT,PXVERR,PXVNAT
+2 FOR I=0:0
SET I=$ORDER(^XTMP("PXVSKX",I))
if I=""
QUIT
Begin DoDot:1
+3 SET PXVZ=$GET(^XTMP("PXVSKX",I,0))
+4 SET PXVNM=$PIECE(PXVZ,U,2)
+5 SET PXVIEN=$$IEN(PXVNM)
+6 IF $PIECE(PXVZ,U)=""
Begin DoDot:2
+7 ;quit if not in file
if '+PXVIEN
QUIT
+8 DO LOCAL(PXVIEN)
End DoDot:2
QUIT
+9 SET PXVZ=PXVIEN_"^"_I_"~"_PXVZ
+10 SET PXVOUT=$$STANDARD(PXVZ)
End DoDot:1
+11 QUIT
+12 ;
STANDARD(PXVZ) ;set up standard record
+1 ; .01 NAME
+2 ; .02 CODE
+3 ; .03 INACTIVE FLAG
+4 ; .11 CPT CODE
+5 ; 3 CODING SYSTEM (multiple)
+6 ; 1201 PRINT NAME
+7 ; 8801 MNEMONIC
+8 ;IEN/0^ROW #~CLASS^NAME^PRINT NAME^STATUS^CPT^MAP NAME
+9 NEW PXV,PXVT,PXVNM,PXVRNM,PXVMAPN,PXVPRT,PXVIEN,PXVERR
+10 if PXVZ=""
QUIT 1
+11 ;duplicate National record
if $DATA(PXVNAT($PIECE(PXVZ,U,4)))
QUIT 1
+12 ;quit if record exists with map name
IF $PIECE(PXVZ,U,7)'=""
if $DATA(^AUTTSK("B",$PIECE(PXVZ,U,7)))
QUIT 1
+13 SET XUMF=1
+14 SET (PXV,PXVIEN(1))=+$PIECE(PXVZ,U)
+15 IF '+$PIECE(PXVZ,U)
Begin DoDot:1
+16 ;get IEN
SET PXVIEN(1)=100+(+$PIECE($PIECE(PXVZ,U,2),"~"))
SET PXV="+1"
End DoDot:1
+17 ;Record Name
SET PXVRNM=$SELECT(PXV="+1":"",1:$PIECE($GET(^AUTTSK(+$PIECE(PXVZ,U),0)),U))
+18 ;Name
SET PXVNM=$$UP^XLFSTR($PIECE(PXVZ,U,3))
+19 ;Print Name
SET PXVPRT=$PIECE(PXVZ,U,4)
+20 ;Map Name
SET PXVMAPN=$PIECE(PXVZ,U,7)
+21 IF PXV="+1"
IF $DATA(^AUTTSK("B",PXVPRT))
Begin DoDot:1
+22 ;if record already exists with print name, use that record
+23 SET (PXV,PXVIEN(1))=$ORDER(^AUTTSK("B",PXVPRT,""))
+24 SET PXVRNM=PXVPRT
End DoDot:1
+25 IF $$UP^XLFSTR(PXVRNM)'=PXVPRT
Begin DoDot:1
+26 ;REPLACE NAME W/PRINT NAME
SET PXVT(9999999.28,PXV_",",.01)=PXVPRT
End DoDot:1
+27 SET PXVT(9999999.28,PXV_",",1201)=$SELECT(PXVMAPN]"":PXVMAPN,1:PXVNM)
+28 ;uneditable prevents FM edit
IF PXV'="+1"
IF (+$PIECE($GET(^AUTTSK(PXV,0)),U,3))
SET $PIECE(^AUTTSK(PXV,0),U,3)=""
+29 SET PXVT(9999999.28,PXV_",",100)="NATIONAL"
+30 SET PXVNAT(PXVPRT)=""
+31 DO UPDATE^DIE("E","PXVT","PXVIEN","PXVERR")
+32 IF $DATA(PXVERR)
DO ERROR(.PXVERR)
DO BMES(PXVIEN(1))
QUIT 1
+33 ;CODING SYSTEM->CODE
+34 IF $PIECE(PXVZ,U,6)
DO MANY(PXVIEN(1),.PXVZ)
+35 QUIT $GET(PXV)_U_$SELECT($DATA(PXVERR):1,1:0)
+36 ;
MANY(IEN,PXVZ) ;populates Coding Multiple
+1 NEW PXVL,PXVCOL,PXVITEM,I,PXVT,PXVERR,PXVLL,PXVREC
+2 ;CODING SYSTEM
+3 SET PXVCOL="CPT"
SET PXVL=1
+4 SET PXVT(9999999.283,"?+"_PXVL_","_IEN_",",.01)=PXVCOL
+5 ;CPT CODES
+6 SET PXVLL=PXVL
SET PXVL=PXVL+1
SET PXVCOL=$PIECE(PXVZ,U,6)
+7 FOR I=1:1
SET PXVITEM=$PIECE(PXVCOL,"|",I)
if PXVITEM=""
QUIT
Begin DoDot:1
+8 SET PXVT(9999999.2831,"?+"_PXVL_",?+"_PXVLL_","_IEN_",",.01)=PXVITEM
+9 SET PXVL=PXVL+1
End DoDot:1
+10 DO UPDATE^DIE(,"PXVT",,"PXVERR")
+11 IF $DATA(PXVERR)
DO ERROR(.PXVERR)
DO BMES(IEN)
+12 QUIT
+13 ;
REMAIN ;
+1 ;loop through file entries with no Class code
+2 NEW PXVIEN,PXVZ
+3 FOR PXVIEN=0:0
SET PXVIEN=$ORDER(^AUTTSK(PXVIEN))
if PXVIEN'>0
QUIT
Begin DoDot:1
+4 SET PXVZ=$GET(^AUTTSK(+PXVIEN,0))
+5 IF $PIECE($GET(^AUTTSK(PXVIEN,100)),U)=""
DO LOCAL(PXVIEN)
End DoDot:1
+6 QUIT
+7 ;
LOCAL(PXVIEN) ;
+1 NEW PXVT,PXVERR
+2 IF $PIECE($GET(^AUTTSK(+PXVIEN,0)),U,3)=""
SET PXVT(9999999.28,PXVIEN_",",.03)="INACTIVE"
+3 SET PXVT(9999999.28,PXVIEN_",",100)="LOCAL"
+4 DO UPDATE^DIE("E","PXVT",,"PXVERR")
+5 IF $DATA(PXVERR)
DO ERROR(.PXVERR)
DO BMES(PXVIEN)
+6 QUIT
+7 ;
DUP() ;
+1 ; Returns 0: No duplicates
+2 ; 1: Duplicate
+3 NEW PXVARY,PXVFLG,PXV,PXVIEN
+4 SET PXVFLG=0
SET PXV=-1
FOR
SET PXV=$ORDER(^AUTTSK("B",PXV))
if PXV=""!(PXVFLG)
QUIT
Begin DoDot:1
+5 FOR PXVIEN=0:0
SET PXVIEN=$ORDER(^AUTTSK("B",PXV,PXVIEN))
if PXVIEN=""
QUIT
Begin DoDot:2
+6 IF '$DATA(PXVARY($$UP^XLFSTR(PXV)))
SET PXVARY($$UP^XLFSTR(PXV))=""
QUIT
+7 SET PXVFLG=1
End DoDot:2
End DoDot:1
+8 QUIT PXVFLG
+9 ;
IEN(PXVNM) ;
+1 ;Returns 0: No match
+2 ; IEN: Matching IEN
+3 NEW PXVI,PXVIEN
+4 SET PXVIEN=""
SET PXVI=""
+5 FOR PXVNM=PXVNM,$$LOW^XLFSTR(PXVNM),$$SENTENCE^XLFSTR(PXVNM),$$TITLE^XLFSTR(PXVNM)
Begin DoDot:1
+6 FOR
SET PXVI=$ORDER(^AUTTSK("B",PXVNM,PXVI))
if PXVI=""
QUIT
Begin DoDot:2
+7 SET PXVIEN=PXVI
End DoDot:2
End DoDot:1
+8 QUIT +PXVIEN
+9 ;
ERROR(PXVERR) ;
+1 IF '$DATA(^XTMP("PXVERR",0))
SET ^XTMP("PXVERR",0)=$$FMADD^XLFDT(DT,30)_"^"_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 SKIN TEST 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 SKIN TEST (#9999999.28) file."
+8 SET PXVTXT(2)="Master File Server Seeding was aborted."
+9 SET PXVTXT(3)="Details of the errors are stored in ^XTMP(""PXVERR"") for the next 30 days."
+10 SET PXVTXT(4)="Please contact Product Support for assistance."
End DoDot:1
+11 IF 'PXVOK
Begin DoDot:1
+12 SET PXVTXT(1)="The SKIN TEST file has been successfully updated."
End DoDot:1
+13 SET XMY(DUZ)=""
+14 DO ^XMD
+15 QUIT
+16 ;
DATA ;deletes data in the SKIN TEST file and restores from backup
+1 NEW PXVI,DA,DIK
+2 SET XUMF=1
+3 IF '$DATA(^XTMP("PXVSKB"))
DO BMES^XPDUTL("SKIN TEST was not restored")
QUIT
+4 FOR PXVI=0:0
SET PXVI=$ORDER(^AUTTSK(PXVI))
if PXVI'>0
QUIT
Begin DoDot:1
+5 SET DA=PXVI
SET DIK="^AUTTSK("
DO ^DIK
End DoDot:1
+6 SET PXVI=-1
FOR
SET PXVI=$ORDER(^XTMP("PXVSKB",9999999.28,PXVI))
if PXVI=""
QUIT
Begin DoDot:1
+7 MERGE ^AUTTSK(PXVI)=^XTMP("PXVSKB",9999999.28,PXVI)
End DoDot:1
+8 QUIT
+9 ;
DELETE(PXVFN) ;
+1 ; Delete data in selected file
+2 NEW PXVG,J,DIK,DA,XUMF
+3 SET PXVG=$$ROOT^DILFD(PXVFN,0,"GL")
+4 SET XUMF=1
+5 FOR J=0:0
SET J=$ORDER(@(PXVG_J_")"))
if J'>0
QUIT
Begin DoDot:1
+6 SET DA=J
SET DIK=PXVG
DO ^DIK
End DoDot:1
+7 QUIT
+8 ;
BMES(IEN) ;
+1 if IEN=""
QUIT
+2 DO BMES^XPDUTL("Fileman error in SKIN TEST record # "_IEN)
+3 QUIT
+4 ;
SHORTNM ;fix short name spelling
+1 NEW PXVI,PXVT,PXVERR
+2 SET PXVI=$ORDER(^AUTTIMM("B","VARICELLA",""))
if PXVI=""
QUIT
Begin DoDot:1
+3 if '$DATA(^AUTTIMM("D","VARCELLA",PXVI))
QUIT
+4 SET PXVT(9999999.14,PXVI_",",.02)="VARICELLA"
+5 DO UPDATE^DIE("E","PXVT")
End DoDot:1
+6 QUIT
+7 ;
CLEAN ;deletes MAX#INSERIES
+1 NEW PXV
+2 FOR PXV=0:0
SET PXV=$ORDER(^AUTTIMM(PXV))
if PXV'>0
QUIT
Begin DoDot:1
+3 if $PIECE($GET(^AUTTIMM(PXV,0)),U,5)=""
QUIT
+4 IF $DATA(^AUTTIMM(PXV,0))
SET $PIECE(^AUTTIMM(PXV,0),U,5)=""
End DoDot:1
+5 QUIT
+6 ;
HDIS ; Call HDIS to begin the 'seeding' process
+1 NEW DOMPTR,TMP
+2 ;sets seeding status of 920 to 'AWAITING ERT UPDATE'
DO SETSTAT^HDISVF01(920,,4)
+3 ;sends bulletin to ERT
DO ERTBULL
+4 SET TMP=$$GETIEN^HDISVF09("IMMUNIZATIONS",.DOMPTR)
+5 DO EN^HDISVCMR(DOMPTR,"")
+6 QUIT
+7 ;
UPD ;
+1 NEW DIC,DIE,DA,DR,Y,XUMF
+2 SET XUMF=1
+3 FOR PXV=0:0
SET DIC="^AUTTSK("
SET DIC(0)="AEQLN"
DO ^DIC
if Y<0
QUIT
Begin DoDot:1
+4 SET DIE="^AUTTSK("
SET DR=".01;.03;3;100;1201;8801"
SET DA=+Y
DO ^DIE
End DoDot:1
+5 QUIT
+6 ;
ERTBULL ;
+1 ;sends bulletin to ERT that 920 is ready for full file update
+2 NEW PXVTMP,HDISP,HDISFLAG,HDISTASK
+3 SET PXVTMP=$$SITE^VASITE()
+4 ;facility name
SET HDISP(1)=$PIECE(PXVTMP,"^",2)
SET HDISP(1)=HDISP(1)_" (#"_($PIECE(PXVTMP,"^",3))_") with Domain/IP Address "_$GET(^XMB("NETNAME"))
+5 SET HDISP(2)="VACCINE INFORMATION STATEMENT (#920)"
+6 ;date/time
SET HDISP(3)=$$NOW^XLFDT
NEW Y
SET Y=HDISP(3)
DO DD^%DT
SET HDISP(3)=Y
+7 ;system type
SET HDISP(4)=$$PROD^XUPROD()
SET HDISP(4)=$SELECT(HDISP(4):"PRODUCTION",1:"TEST")
+8 ;facility number
SET HDISP(5)=$PIECE(PXVTMP,"^",3)
+9 SET HDISP(6)=920
+10 SET HDISFLAG("FROM")="HDIS Data Standardization Server"
+11 ;
DO TASKBULL^XMXAPI(DUZ,"HDIS NOTIFY ERT",.HDISP,,,.HDISFLAG,.HDISTASK)
+12 QUIT
+13 ;
RESTORE(PXVF) ;
+1 NEW PXVGL,PXVI
+2 IF (PXVF'=920.1)&(PXVF'=920.2)&(PXVF'=920.3)&(PXVF'=920.4)&(PXVF'=920.5)&(PXVF'=9999999.04)&(PXVF'=9999999.14)
Begin DoDot:1
+3 WRITE !,"Only 920.1, 920.2, 920.3, 920.4, 920.5,9999999.04 and 9999999.14 can be restored using this API."
End DoDot:1
QUIT
+4 IF '$DATA(^XTMP("PXVBKUP",PXVF))
WRITE !,"Data backup has been purged. Restore is aborted."
QUIT
+5 DO DELETE(PXVF)
+6 SET PXVGL=$$ROOT^DILFD(PXVF)
+7 SET PXVI=-1
FOR
SET PXVI=$ORDER(^XTMP("PXVBKUP",PXVF,PXVI))
if PXVI=""
QUIT
Begin DoDot:1
+8 MERGE @(PXVGL_""""_PXVI_""""_")")=^XTMP("PXVBKUP",PXVF,PXVI)
End DoDot:1
+9 QUIT
