XUPCH117 ;ISF/RWF - PATCH XU*8*117 ;06/02/99 13:35
;;8.0;KERNEL;**117**;Apr 10, 1999
Q
POST ;Update the package file with the data
N DATA,IX
F IX=1:1 S DATA=$T(DATA+IX) Q:DATA="" S DATA=$P(DATA,";;",2) D UPDATE
D DEL ;Remove old fields.
D FMDC ;Add package
Q
UPDATE ;Do the work
N D,J,L,NIEN,PIEN
S NIEN=$O(^DIC(9.4,"B",$P(DATA,U),0)),PIEN=$O(^DIC(9.4,"C",$P(DATA,U,2),0))
I +NIEN,+PIEN,NIEN'=PIEN D
. D BMES^XPDUTL("For package "_$P(DATA,U)_" with Prefix "_$P(DATA,U,2))
. D BMES^XPDUTL("NAME ("_NIEN_") and PREFIX ("_PIEN_") don't point to the same record.")
. Q
I 'NIEN,'PIEN D NEW
S:'PIEN PIEN=NIEN S:'NIEN NIEN=PIEN S J=$S(NIEN<PIEN:NIEN,1:PIEN)
D WORK(J)
Q
NEW ;
N FDA,XIEN
S FDA(9.4,"+1,",.01)=$P(DATA,U),FDA(9.4,"+1,",1)=$P(DATA,U,2)
D UPDATE^DIE("","FDA","XIEN") S (NIEN,PIEN)=XIEN(1)
Q
WORK(DA) ;
N I,K,FDA,IEN
S K=$P($G(^DIC(9.4,DA,0)),U) I K'=$P(DATA,U) S FDA(9.4,DA_",",.01)=$P(DATA,U)
F K=3:1 S I=$P(DATA,U,K) Q:I="" S FDA(9.4014,"?+"_K_","_DA_",",.01)=I
I $D(FDA) D UPDATE^DIE("","FDA","IEN")
Q
FMDC ;Setup FMDC version 1.0
N FDA,IEN,DA
S DA=$O(^DIC(9.4,"C","FMDC",0)) Q:'DA
S FDA(9.4,DA_",",13)="1.0",FDA(9.49,"?+2,"_DA_",",.01)="1.0",IEN(2)=1
D UPDATE^DIE("","FDA","IEN") ;I $D(^TMP("DIERR",$J)) W !,"ERROR"
Q
DEL ;Delete DD fields
N IX,DATA,DA,FILE,FLD,XFDA,X,XIEN
;DD(9.4 fields to remove
;F I=1:1 S X=$P(DATA,";",I) Q:X="" W !,X,?5,$P($G(^DD(9.4,X,0)),U)
S FILE=9.4,DATA="4;5;11.1;11.4;11.5;11.6;11.7;12;200.1;200.2;1920;1933",DA=0,XDR=""
F I=1:1 S X=$P(DATA,";",I) Q:X="" I '(+$P($G(^DD(9.4,X,0),"^1"),U,2)) S XDR=XDR_X_"///@;"
F S DA=$O(^DIC(FILE,DA)) Q:DA'>0 D
. S DIE="^DIC(9.4,",DR=XDR D ^DIE
. Q
D DELLN
;DD(9.4,DA(1),22, to remove
S FILE=9.49,DATA="51;61;62;63"
D DELLN
Q
DELLN ;
N IJ,DIK,DA,FLD
F IJ=1:1 S FLD=$P(DATA,";",IJ) Q:FLD="" D
. K DA,DIK
. S DO=$P($G(^DD(FILE,FLD,0)),U,2) Q:DO=""
. I +DO D SUBFLD(FILE,+DO) Q
. S DA=FLD,DIK="^DD("_FILE_",",DA(1)=FILE D ^DIK
. Q
Q
SUBFLD(FL,FD) ;
N DIU
S DIU=FD,DIU(0)="DS" D EN^DIU2
Q
BLD ;BUILD DATA
D HOME^%ZIS
N PK,DA,IX
S PK=0,U="^",IO="SDP.DAT"
O IO:NEWVERSION
F S PK=$O(^RWF("PATCH",PK)) Q:PK'>0 S X=$G(^(PK,0)) D
. S X=$C(9)_";;"_$P(X_"^^","^",1,2),Y=""
. F IX=0:0 S IX=$O(^RWF("PATCH",PK,14,IX)) Q:IX'>0 S Y=Y_"^"_$P(^(IX,0),U)
. S:$L(Y) X=X_Y U IO(0) W !,X
. U IO W X,!
. Q
C IO
Q
DATA ;
;;ACCOUNTS RECEIVABLE^PRCA^PRY^RC
;;ADVERSE REACTION TRACKING^GMRA^GMA
;;ASISTS^OOPS
;;AUTHORIZATION/SUBSCRIPTION^USR
;;AUTO REPLENISHMENT/WARD STOCK^PSGW
;;AUTOMATED INFO COLLECTION SYS^IBD
;;AUTOMATED LAB INSTRUMENTS^LA
;;AUTOMATED MED INFO EXCHANGE^DVBA^DVBE^DVBX^DVBY
;;CAPACITY MANAGEMENT - RUM^KMPR
;;CLINICAL INFO RESOURCE NETWORK^RG^MRF
;;CLINICAL MONITORING SYSTEM^QAM
;;CMOP^PSX
;;CONSULT/REQUEST TRACKING^GMRC^GMRS^GMRT
;;CONTROLLED SUBSTANCES^PSD
;;CPT/HCPCS CODES^ICPT^DGYA
;;DENTAL^DENT
;;DIETETICS^FH
;;DISCHARGE SUMMARY^GMRD^GMRE
;;DRG GROUPER^ICD^IC
;;DRUG ACCOUNTABILITY^PSA
;;DSS EXTRACTS^ECX
;;EEO COMPLAINT TRACKING^EEO
;;ENGINEERING^EN
;;EQUIPMENT/TURN-IN REQUIEST^PRCN
;;EVENT CAPTURE^EC
;;FEE BASIS^FB
;;FILEMAN DELPHI COMPONENTS^FMDC
;;GEN. MED. REC. - GENERATOR^GMRG
;;GEN. MED. REC. - I/O^GMRY
;;GEN. MED. REC. - VITALS^GMRV
;;GENERIC CODE SHEET^GEC
;;HEALTH LEVEL SEVEN^HL
;;HEALTH SUMMARY^GMTS
;;HINQ^DVB^DVBC^DVBU^DVBV^DVBW^DVY
;;HOSPITAL BASED HOME CARE^HBH
;;ICR - IMMUNOLOGY CASE REGISTRY^IMR
;;IFCAP^PRC^PRX
;;IMAGING^MAG^ZMAG
;;INCIDENT REPORTING^QAN
;;INCOME VERIFICATION MATCH^IVM
;;INPATIENT MEDICATIONS^PSJ^PSIV^PSG
;;INTEGRATED BILLING^IB^PRQ
;;INTEGRATED PATIENT FUNDS^PRPF
;;INTERIM MANAGEMENT SUPPORT^ECT
;;KERNEL^XU^USC^XLF^XPD^XNOA^XQ^ZI^ZOSF^ZOSV^ZT
;;LAB SERVICE^LR^LS
;;LEXICON UTILITY^LEX^GMPT
;;LIBRARY^LBR^LBRS
;;LIST MANAGER^VALM
;;MAILMAN^XM
;;MCCR NATIONAL DATABASE - FIELD^PRQS
;;MEDICINE^MC
;;MENTAL HEALTH^YS^RUCL
;;MINIMAL PATIENT DATASET^VAM
;;Missing Patient Register^MPR
;;NATIONAL DRUG FILE^PSN
;;NATIONAL LABORATORY TEST^NLT
;;NETWORK HEALTH EXCHANGE^AFJX
;;NURSING SERVICE^NUR
;;OCCURRENCE SCREEN^QAO
;;ONCOLOGY^ONC
;;ORDER ENTRY/RESULTS REPORTING^OR^OCX
;;OUTPATIENT PHARMACY^PSO^APSP
;;PAID^PRS
;;PATIENT DATA EXCHANGE^VAQ
;;PATIENT FEEDBACK^A4A8^QAF
;;PATIENT REPRESENTATIVE^QAC
;;PCE PATIENT CARE ENCOUNTER^PX^EFDP^VSIT
;;PHARMACY BENEFITS MANAGEMENT^PSU
;;PHARMACY DATA MANAGEMENT^PSS
;;PHARMACY PRESCRIPTION PRACTICE^PPP
;;POLICE & SECURITY^ES
;;PROBLEM LIST^GMPL
;;PROGRESS NOTES^GMRP^GMRQ^GMRR
;;PROSTHETICS^RMPR^RMPO^RMPS
;;QUALITY ASSURANCE INTEGRATION^QAQ
;;QUALITY IMPROVEMENT CHECKLIST^QIP
;;QUASAR^ACKQ
;;RADIOLOGY/NUCLEAR MEDICINE^RA
;;RECORD TRACKING^RT
;;REGISTRATION^DG^DGJ^DGQE^DPT^VA^VIC
;;REMOTE ORDER/ENTRY SYSTEM^RMPF^RMPJ
;;RPC BROKER^XWB
;;SAGG PROJECT^KMPS^A1B5
;;SCHEDULING^SD^SC
;;SOCIAL WORK^SOW^SWBH^SWFG
;;SPINAL CORD DYSFUNCTION^SPN
;;SURGERY^SR
;;SURVEY GENERATOR^QAP
;;TEXT INTEGRATION UTILITIES^TIU
;;TOOLKIT^XT^XD^XIN^XPAR^XQAB^XUC^XUR^ZIN^ZTED
;;UTILIZATION MANAGEMENT ROLLUP^IBQ
;;VA FILEMAN^DI^DD^DM
;;VISUAL IMPAIRMENT SERVICE TEAM^ANRV
;;VOLUNTARY TIMEKEEPING^ABSV^ABS2
;;WOMEN'S HEALTH^WV
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUPCH117 5313 printed Nov 22, 2024@17:21:41 Page 2
XUPCH117 ;ISF/RWF - PATCH XU*8*117 ;06/02/99 13:35
+1 ;;8.0;KERNEL;**117**;Apr 10, 1999
+2 QUIT
POST ;Update the package file with the data
+1 NEW DATA,IX
+2 FOR IX=1:1
SET DATA=$TEXT(DATA+IX)
if DATA=""
QUIT
SET DATA=$PIECE(DATA,";;",2)
DO UPDATE
+3 ;Remove old fields.
DO DEL
+4 ;Add package
DO FMDC
+5 QUIT
UPDATE ;Do the work
+1 NEW D,J,L,NIEN,PIEN
+2 SET NIEN=$ORDER(^DIC(9.4,"B",$PIECE(DATA,U),0))
SET PIEN=$ORDER(^DIC(9.4,"C",$PIECE(DATA,U,2),0))
+3 IF +NIEN
IF +PIEN
IF NIEN'=PIEN
Begin DoDot:1
+4 DO BMES^XPDUTL("For package "_$PIECE(DATA,U)_" with Prefix "_$PIECE(DATA,U,2))
+5 DO BMES^XPDUTL("NAME ("_NIEN_") and PREFIX ("_PIEN_") don't point to the same record.")
+6 QUIT
End DoDot:1
+7 IF 'NIEN
IF 'PIEN
DO NEW
+8 if 'PIEN
SET PIEN=NIEN
if 'NIEN
SET NIEN=PIEN
SET J=$SELECT(NIEN<PIEN:NIEN,1:PIEN)
+9 DO WORK(J)
+10 QUIT
NEW ;
+1 NEW FDA,XIEN
+2 SET FDA(9.4,"+1,",.01)=$PIECE(DATA,U)
SET FDA(9.4,"+1,",1)=$PIECE(DATA,U,2)
+3 DO UPDATE^DIE("","FDA","XIEN")
SET (NIEN,PIEN)=XIEN(1)
+4 QUIT
WORK(DA) ;
+1 NEW I,K,FDA,IEN
+2 SET K=$PIECE($GET(^DIC(9.4,DA,0)),U)
IF K'=$PIECE(DATA,U)
SET FDA(9.4,DA_",",.01)=$PIECE(DATA,U)
+3 FOR K=3:1
SET I=$PIECE(DATA,U,K)
if I=""
QUIT
SET FDA(9.4014,"?+"_K_","_DA_",",.01)=I
+4 IF $DATA(FDA)
DO UPDATE^DIE("","FDA","IEN")
+5 QUIT
FMDC ;Setup FMDC version 1.0
+1 NEW FDA,IEN,DA
+2 SET DA=$ORDER(^DIC(9.4,"C","FMDC",0))
if 'DA
QUIT
+3 SET FDA(9.4,DA_",",13)="1.0"
SET FDA(9.49,"?+2,"_DA_",",.01)="1.0"
SET IEN(2)=1
+4 ;I $D(^TMP("DIERR",$J)) W !,"ERROR"
DO UPDATE^DIE("","FDA","IEN")
+5 QUIT
DEL ;Delete DD fields
+1 NEW IX,DATA,DA,FILE,FLD,XFDA,X,XIEN
+2 ;DD(9.4 fields to remove
+3 ;F I=1:1 S X=$P(DATA,";",I) Q:X="" W !,X,?5,$P($G(^DD(9.4,X,0)),U)
+4 SET FILE=9.4
SET DATA="4;5;11.1;11.4;11.5;11.6;11.7;12;200.1;200.2;1920;1933"
SET DA=0
SET XDR=""
+5 FOR I=1:1
SET X=$PIECE(DATA,";",I)
if X=""
QUIT
IF '(+$PIECE($GET(^DD(9.4,X,0),"^1"),U,2))
SET XDR=XDR_X_"///@;"
+6 FOR
SET DA=$ORDER(^DIC(FILE,DA))
if DA'>0
QUIT
Begin DoDot:1
+7 SET DIE="^DIC(9.4,"
SET DR=XDR
DO ^DIE
+8 QUIT
End DoDot:1
+9 DO DELLN
+10 ;DD(9.4,DA(1),22, to remove
+11 SET FILE=9.49
SET DATA="51;61;62;63"
+12 DO DELLN
+13 QUIT
DELLN ;
+1 NEW IJ,DIK,DA,FLD
+2 FOR IJ=1:1
SET FLD=$PIECE(DATA,";",IJ)
if FLD=""
QUIT
Begin DoDot:1
+3 KILL DA,DIK
+4 SET DO=$PIECE($GET(^DD(FILE,FLD,0)),U,2)
if DO=""
QUIT
+5 IF +DO
DO SUBFLD(FILE,+DO)
QUIT
+6 SET DA=FLD
SET DIK="^DD("_FILE_","
SET DA(1)=FILE
DO ^DIK
+7 QUIT
End DoDot:1
+8 QUIT
SUBFLD(FL,FD) ;
+1 NEW DIU
+2 SET DIU=FD
SET DIU(0)="DS"
DO EN^DIU2
+3 QUIT
BLD ;BUILD DATA
+1 DO HOME^%ZIS
+2 NEW PK,DA,IX
+3 SET PK=0
SET U="^"
SET IO="SDP.DAT"
+4 OPEN IO:NEWVERSION
+5 FOR
SET PK=$ORDER(^RWF("PATCH",PK))
if PK'>0
QUIT
SET X=$GET(^(PK,0))
Begin DoDot:1
+6 SET X=$CHAR(9)_";;"_$PIECE(X_"^^","^",1,2)
SET Y=""
+7 FOR IX=0:0
SET IX=$ORDER(^RWF("PATCH",PK,14,IX))
if IX'>0
QUIT
SET Y=Y_"^"_$PIECE(^(IX,0),U)
+8 if $LENGTH(Y)
SET X=X_Y
USE IO(0)
WRITE !,X
+9 USE IO
WRITE X,!
+10 QUIT
End DoDot:1
+11 CLOSE IO
+12 QUIT
DATA ;
+1 ;;ACCOUNTS RECEIVABLE^PRCA^PRY^RC
+2 ;;ADVERSE REACTION TRACKING^GMRA^GMA
+3 ;;ASISTS^OOPS
+4 ;;AUTHORIZATION/SUBSCRIPTION^USR
+5 ;;AUTO REPLENISHMENT/WARD STOCK^PSGW
+6 ;;AUTOMATED INFO COLLECTION SYS^IBD
+7 ;;AUTOMATED LAB INSTRUMENTS^LA
+8 ;;AUTOMATED MED INFO EXCHANGE^DVBA^DVBE^DVBX^DVBY
+9 ;;CAPACITY MANAGEMENT - RUM^KMPR
+10 ;;CLINICAL INFO RESOURCE NETWORK^RG^MRF
+11 ;;CLINICAL MONITORING SYSTEM^QAM
+12 ;;CMOP^PSX
+13 ;;CONSULT/REQUEST TRACKING^GMRC^GMRS^GMRT
+14 ;;CONTROLLED SUBSTANCES^PSD
+15 ;;CPT/HCPCS CODES^ICPT^DGYA
+16 ;;DENTAL^DENT
+17 ;;DIETETICS^FH
+18 ;;DISCHARGE SUMMARY^GMRD^GMRE
+19 ;;DRG GROUPER^ICD^IC
+20 ;;DRUG ACCOUNTABILITY^PSA
+21 ;;DSS EXTRACTS^ECX
+22 ;;EEO COMPLAINT TRACKING^EEO
+23 ;;ENGINEERING^EN
+24 ;;EQUIPMENT/TURN-IN REQUIEST^PRCN
+25 ;;EVENT CAPTURE^EC
+26 ;;FEE BASIS^FB
+27 ;;FILEMAN DELPHI COMPONENTS^FMDC
+28 ;;GEN. MED. REC. - GENERATOR^GMRG
+29 ;;GEN. MED. REC. - I/O^GMRY
+30 ;;GEN. MED. REC. - VITALS^GMRV
+31 ;;GENERIC CODE SHEET^GEC
+32 ;;HEALTH LEVEL SEVEN^HL
+33 ;;HEALTH SUMMARY^GMTS
+34 ;;HINQ^DVB^DVBC^DVBU^DVBV^DVBW^DVY
+35 ;;HOSPITAL BASED HOME CARE^HBH
+36 ;;ICR - IMMUNOLOGY CASE REGISTRY^IMR
+37 ;;IFCAP^PRC^PRX
+38 ;;IMAGING^MAG^ZMAG
+39 ;;INCIDENT REPORTING^QAN
+40 ;;INCOME VERIFICATION MATCH^IVM
+41 ;;INPATIENT MEDICATIONS^PSJ^PSIV^PSG
+42 ;;INTEGRATED BILLING^IB^PRQ
+43 ;;INTEGRATED PATIENT FUNDS^PRPF
+44 ;;INTERIM MANAGEMENT SUPPORT^ECT
+45 ;;KERNEL^XU^USC^XLF^XPD^XNOA^XQ^ZI^ZOSF^ZOSV^ZT
+46 ;;LAB SERVICE^LR^LS
+47 ;;LEXICON UTILITY^LEX^GMPT
+48 ;;LIBRARY^LBR^LBRS
+49 ;;LIST MANAGER^VALM
+50 ;;MAILMAN^XM
+51 ;;MCCR NATIONAL DATABASE - FIELD^PRQS
+52 ;;MEDICINE^MC
+53 ;;MENTAL HEALTH^YS^RUCL
+54 ;;MINIMAL PATIENT DATASET^VAM
+55 ;;Missing Patient Register^MPR
+56 ;;NATIONAL DRUG FILE^PSN
+57 ;;NATIONAL LABORATORY TEST^NLT
+58 ;;NETWORK HEALTH EXCHANGE^AFJX
+59 ;;NURSING SERVICE^NUR
+60 ;;OCCURRENCE SCREEN^QAO
+61 ;;ONCOLOGY^ONC
+62 ;;ORDER ENTRY/RESULTS REPORTING^OR^OCX
+63 ;;OUTPATIENT PHARMACY^PSO^APSP
+64 ;;PAID^PRS
+65 ;;PATIENT DATA EXCHANGE^VAQ
+66 ;;PATIENT FEEDBACK^A4A8^QAF
+67 ;;PATIENT REPRESENTATIVE^QAC
+68 ;;PCE PATIENT CARE ENCOUNTER^PX^EFDP^VSIT
+69 ;;PHARMACY BENEFITS MANAGEMENT^PSU
+70 ;;PHARMACY DATA MANAGEMENT^PSS
+71 ;;PHARMACY PRESCRIPTION PRACTICE^PPP
+72 ;;POLICE & SECURITY^ES
+73 ;;PROBLEM LIST^GMPL
+74 ;;PROGRESS NOTES^GMRP^GMRQ^GMRR
+75 ;;PROSTHETICS^RMPR^RMPO^RMPS
+76 ;;QUALITY ASSURANCE INTEGRATION^QAQ
+77 ;;QUALITY IMPROVEMENT CHECKLIST^QIP
+78 ;;QUASAR^ACKQ
+79 ;;RADIOLOGY/NUCLEAR MEDICINE^RA
+80 ;;RECORD TRACKING^RT
+81 ;;REGISTRATION^DG^DGJ^DGQE^DPT^VA^VIC
+82 ;;REMOTE ORDER/ENTRY SYSTEM^RMPF^RMPJ
+83 ;;RPC BROKER^XWB
+84 ;;SAGG PROJECT^KMPS^A1B5
+85 ;;SCHEDULING^SD^SC
+86 ;;SOCIAL WORK^SOW^SWBH^SWFG
+87 ;;SPINAL CORD DYSFUNCTION^SPN
+88 ;;SURGERY^SR
+89 ;;SURVEY GENERATOR^QAP
+90 ;;TEXT INTEGRATION UTILITIES^TIU
+91 ;;TOOLKIT^XT^XD^XIN^XPAR^XQAB^XUC^XUR^ZIN^ZTED
+92 ;;UTILIZATION MANAGEMENT ROLLUP^IBQ
+93 ;;VA FILEMAN^DI^DD^DM
+94 ;;VISUAL IMPAIRMENT SERVICE TEAM^ANRV
+95 ;;VOLUNTARY TIMEKEEPING^ABSV^ABS2
+96 ;;WOMEN'S HEALTH^WV
