XUPCH117.m

XUPCH117 ;ISF/RWF - PATCH XU*8*117 ;06/02/99  13:35 [ 04/02/2003   8:29 AM ]

 ;;8.0;KERNEL;**1007**;APR 1, 2003

 ;;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

XUPCH117  ;ISF/RWF - PATCH XU*8*117 ;06/02/99  13:35 [ 04/02/2003   8:29 AM ]

 +1       ;;8.0;KERNEL;**1007**;APR 1, 2003

 +2       ;;8.0;KERNEL;**117**;Apr 10, 1999

 +3        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