ORY269 ;ISP/RFR - DATA DICTIONARY CLEANUP ;12/15/2015 12:01
;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997;Build 85
Q
PRE ;Pre-install
;IF THE FILE ALREADY EXITS, DELETE THE DATA DICTIONARY
I $D(^DIC(100.05))>0 D
.N FILE
.D FILE^DID(100.05,,"NAME","FILE")
.D BMES^XPDUTL("Deleting existing "_$G(FILE("NAME"))_" data dictionary while preserving data...")
.N DIU
.S DIU="^ORD(100.05,",DIU(0)="T"
.D EN^DIU2
.D MES^XPDUTL("DONE")
Q
POST ;Post-install
I '$D(^ORD(100.8,99)) D
.D BMES^XPDUTL("Creating new ORDER CHECKS entry...")
.N FDA,IEN,DESCRIPTION,ERROR
.S FDA(100.8,"+1,",.01)="REMOTE DATA UNAVAILABLE"
.S FDA(100.8,"+1,",2)="DESCRIPTION"
.S DESCRIPTION(1,0)="Triggered by the order checking system, this order check is generated when"
.S DESCRIPTION(2,0)="the remote data interoperability (RDI) client is unable to obtain all"
.S DESCRIPTION(3,0)="available data from the Health Data Repository (HDR)."
.S IEN(1)=99
.D UPDATE^DIE(,"FDA","IEN","ERROR")
.I $D(ERROR) D ERROR("Unable to add the REMOTE DATA UNAVAILABLE entry",.ERROR)
.I '$D(ERROR) D MES^XPDUTL("DONE")
D ^ORY269ES
N FILE
I $Q(^ORD(100.05,0))']"^ORD(100.05," D BMES^XPDUTL("No data to convert.") Q
D FILE^DID(100.05,,"NAME","FILE")
D BMES^XPDUTL("Converting existing data in the "_$G(FILE("NAME"))_" file...")
N XPDIDTOT,RECCOUNT
S XPDIDTOT=+$P(^ORD(100.05,0),U,4),RECCOUNT=0
D UPDATE^XPDID(RECCOUNT)
N I
S I=0 F S I=$O(^ORD(100.05,I)) Q:'I D
.I $D(^ORD(100.05,I,2)) D
..N COUNT
..S COUNT=$O(^ORD(100.05,I,2,"?"),-1)
..I $P(^ORD(100.05,I,2,0),U,3,4)'=(COUNT_U_COUNT) S $P(^ORD(100.05,I,2,0),U,3,5)=COUNT_U_COUNT_U_DT
.I $D(^ORD(100.05,I,4)),('$D(^ORD(100.05,I,5))) D
..N X,P01
..S X=0 F S X=$O(^ORD(100.05,I,4,X)) Q:'X D
...N DAT,DRG,CUA,INT,DB,LOC,OH,SEV
...S DAT=^ORD(100.05,I,4,X,0),DRG=$P(DAT,U),LOC=$P(DAT,U,2),CUA=$P(DAT,U,3),INT=$P(DAT,U,5),DB=$P(DAT,U,6)
...S OH=$P(DAT,U,7),SEV=$P(DAT,U,8)
...I $G(DRG)]"",($D(^PSDRUG(DRG))) D
....S ^ORD(100.05,I,5,0)="100.06PA^1^1",^ORD(100.05,I,5,1,0)=DRG,^ORD(100.05,I,5,"B",DRG,1)=""
....S $P(^ORD(100.05,I,4,X,0),U)="" K ^ORD(100.05,I,4,"B",DRG,X)
...I $G(INT)]"",($D(^APSPQA(32.4,INT))) S ^ORD(100.05,I,8)=INT,$P(^ORD(100.05,I,4,X,0),U,5)=""
...I $G(CUA)[";" D
....N NODE S NODE=U_$P(CUA,";",2)_$P(CUA,";")_")"
....I $D(@NODE) S $P(^ORD(100.05,I,4,X,0),U,2)=CUA,$P(^ORD(100.05,I,4,X,0),U,3)=""
...I "^L^R^"[(U_$G(LOC)_U) S $P(^ORD(100.05,I,4,X,0),U,3)=LOC
...I "^C^V^"[(U_$G(DB)_U) S $P(^ORD(100.05,I,8),U,4)=DB,$P(^ORD(100.05,I,4,X,0),U,6)=""
...I $P(^ORD(100.05,I,4,X,0),U)="" D
....I $P(^ORD(100.05,I,4,X,0),U,2)["50.605" D
.....S $P(^ORD(100.05,I,4,X,0),U)=$$GET1^DIQ(50.605,$P($P(^ORD(100.05,I,4,X,0),U,2),";")_",",1)
....I $P(^ORD(100.05,I,4,X,0),U,2)'["50.605" D
.....S $P(^ORD(100.05,I,4,X,0),U)=$$EXTERNAL^DILFD(100.517,2,,$P(^ORD(100.05,I,4,X,0),U,2))
....S P01=$P(^ORD(100.05,I,4,X,0),U) I P01'="" S ^ORD(100.05,I,4,"B",P01,X)=""
....I P01="" D
.....N MSGS S MSGS(1)="Record #"_I_" is corrupt.",MSGS(2)="The .01 field does not have a valid value."
.....S MSGS(3)="Please contact your help desk for assistance in correcting this record."
.....D BMES^XPDUTL(.MSGS)
...I "^O^H^"[(U_$G(OH)_U) S $P(^ORD(100.05,I,4,X,0),U,6)=OH,$P(^ORD(100.05,I,4,X,0),U,7)=""
...I "^1^2^3^"[(U_$G(SEV)_U) S $P(^ORD(100.05,I,4,X,0),U,7)=SEV,$P(^ORD(100.05,I,4,X,0),U,8)=""
...I $L(^ORD(100.05,I,4,X,0),U)=8 S ^ORD(100.05,I,4,X,0)=$P(^ORD(100.05,I,4,X,0),U,1,7)
.I $D(^ORD(100.05,I,15)) D
..S $P(^ORD(100.05,I,11),U,3)=$P(^ORD(100.05,I,15),U,1)
..K ^ORD(100.05,I,15)
.S RECCOUNT=RECCOUNT+1 D:'(RECCOUNT#100) UPDATE^XPDID(RECCOUNT)
D UPDATE^XPDID(XPDIDTOT)
D MES^XPDUTL("DONE")
Q
ERROR(TEXT,ERROR) ;OUTPUT FILEMAN ERROR MESSAGE(S)
N ORMSG,IDX
S ORMSG(1)=" "
S ORMSG(2)="ERROR: "_TEXT_"."
S ORMSG(3)="VA FileMan Error #"_ERROR("DIERR",1)_":"
F IDX=1:1:+$O(ERROR("DIERR",1,"TEXT","A"),-1) D
.S ORMSG(IDX+2)=ERROR("DIERR",1,"TEXT",IDX)
D BMES^XPDUTL(.ORMSG)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY269 4040 printed Oct 16, 2024@18:40:46 Page 2
ORY269 ;ISP/RFR - DATA DICTIONARY CLEANUP ;12/15/2015 12:01
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997;Build 85
+2 QUIT
PRE ;Pre-install
+1 ;IF THE FILE ALREADY EXITS, DELETE THE DATA DICTIONARY
+2 IF $DATA(^DIC(100.05))>0
Begin DoDot:1
+3 NEW FILE
+4 DO FILE^DID(100.05,,"NAME","FILE")
+5 DO BMES^XPDUTL("Deleting existing "_$GET(FILE("NAME"))_" data dictionary while preserving data...")
+6 NEW DIU
+7 SET DIU="^ORD(100.05,"
SET DIU(0)="T"
+8 DO EN^DIU2
+9 DO MES^XPDUTL("DONE")
End DoDot:1
+10 QUIT
POST ;Post-install
+1 IF '$DATA(^ORD(100.8,99))
Begin DoDot:1
+2 DO BMES^XPDUTL("Creating new ORDER CHECKS entry...")
+3 NEW FDA,IEN,DESCRIPTION,ERROR
+4 SET FDA(100.8,"+1,",.01)="REMOTE DATA UNAVAILABLE"
+5 SET FDA(100.8,"+1,",2)="DESCRIPTION"
+6 SET DESCRIPTION(1,0)="Triggered by the order checking system, this order check is generated when"
+7 SET DESCRIPTION(2,0)="the remote data interoperability (RDI) client is unable to obtain all"
+8 SET DESCRIPTION(3,0)="available data from the Health Data Repository (HDR)."
+9 SET IEN(1)=99
+10 DO UPDATE^DIE(,"FDA","IEN","ERROR")
+11 IF $DATA(ERROR)
DO ERROR("Unable to add the REMOTE DATA UNAVAILABLE entry",.ERROR)
+12 IF '$DATA(ERROR)
DO MES^XPDUTL("DONE")
End DoDot:1
+13 DO ^ORY269ES
+14 NEW FILE
+15 IF $QUERY(^ORD(100.05,0))']"^ORD(100.05,"
DO BMES^XPDUTL("No data to convert.")
QUIT
+16 DO FILE^DID(100.05,,"NAME","FILE")
+17 DO BMES^XPDUTL("Converting existing data in the "_$GET(FILE("NAME"))_" file...")
+18 NEW XPDIDTOT,RECCOUNT
+19 SET XPDIDTOT=+$PIECE(^ORD(100.05,0),U,4)
SET RECCOUNT=0
+20 DO UPDATE^XPDID(RECCOUNT)
+21 NEW I
+22 SET I=0
FOR
SET I=$ORDER(^ORD(100.05,I))
if 'I
QUIT
Begin DoDot:1
+23 IF $DATA(^ORD(100.05,I,2))
Begin DoDot:2
+24 NEW COUNT
+25 SET COUNT=$ORDER(^ORD(100.05,I,2,"?"),-1)
+26 IF $PIECE(^ORD(100.05,I,2,0),U,3,4)'=(COUNT_U_COUNT)
SET $PIECE(^ORD(100.05,I,2,0),U,3,5)=COUNT_U_COUNT_U_DT
End DoDot:2
+27 IF $DATA(^ORD(100.05,I,4))
IF ('$DATA(^ORD(100.05,I,5)))
Begin DoDot:2
+28 NEW X,P01
+29 SET X=0
FOR
SET X=$ORDER(^ORD(100.05,I,4,X))
if 'X
QUIT
Begin DoDot:3
+30 NEW DAT,DRG,CUA,INT,DB,LOC,OH,SEV
+31 SET DAT=^ORD(100.05,I,4,X,0)
SET DRG=$PIECE(DAT,U)
SET LOC=$PIECE(DAT,U,2)
SET CUA=$PIECE(DAT,U,3)
SET INT=$PIECE(DAT,U,5)
SET DB=$PIECE(DAT,U,6)
+32 SET OH=$PIECE(DAT,U,7)
SET SEV=$PIECE(DAT,U,8)
+33 IF $GET(DRG)]""
IF ($DATA(^PSDRUG(DRG)))
Begin DoDot:4
+34 SET ^ORD(100.05,I,5,0)="100.06PA^1^1"
SET ^ORD(100.05,I,5,1,0)=DRG
SET ^ORD(100.05,I,5,"B",DRG,1)=""
+35 SET $PIECE(^ORD(100.05,I,4,X,0),U)=""
KILL ^ORD(100.05,I,4,"B",DRG,X)
End DoDot:4
+36 IF $GET(INT)]""
IF ($DATA(^APSPQA(32.4,INT)))
SET ^ORD(100.05,I,8)=INT
SET $PIECE(^ORD(100.05,I,4,X,0),U,5)=""
+37 IF $GET(CUA)[";"
Begin DoDot:4
+38 NEW NODE
SET NODE=U_$PIECE(CUA,";",2)_$PIECE(CUA,";")_")"
+39 IF $DATA(@NODE)
SET $PIECE(^ORD(100.05,I,4,X,0),U,2)=CUA
SET $PIECE(^ORD(100.05,I,4,X,0),U,3)=""
End DoDot:4
+40 IF "^L^R^"[(U_$GET(LOC)_U)
SET $PIECE(^ORD(100.05,I,4,X,0),U,3)=LOC
+41 IF "^C^V^"[(U_$GET(DB)_U)
SET $PIECE(^ORD(100.05,I,8),U,4)=DB
SET $PIECE(^ORD(100.05,I,4,X,0),U,6)=""
+42 IF $PIECE(^ORD(100.05,I,4,X,0),U)=""
Begin DoDot:4
+43 IF $PIECE(^ORD(100.05,I,4,X,0),U,2)["50.605"
Begin DoDot:5
+44 SET $PIECE(^ORD(100.05,I,4,X,0),U)=$$GET1^DIQ(50.605,$PIECE($PIECE(^ORD(100.05,I,4,X,0),U,2),";")_",",1)
End DoDot:5
+45 IF $PIECE(^ORD(100.05,I,4,X,0),U,2)'["50.605"
Begin DoDot:5
+46 SET $PIECE(^ORD(100.05,I,4,X,0),U)=$$EXTERNAL^DILFD(100.517,2,,$PIECE(^ORD(100.05,I,4,X,0),U,2))
End DoDot:5
+47 SET P01=$PIECE(^ORD(100.05,I,4,X,0),U)
IF P01'=""
SET ^ORD(100.05,I,4,"B",P01,X)=""
+48 IF P01=""
Begin DoDot:5
+49 NEW MSGS
SET MSGS(1)="Record #"_I_" is corrupt."
SET MSGS(2)="The .01 field does not have a valid value."
+50 SET MSGS(3)="Please contact your help desk for assistance in correcting this record."
+51 DO BMES^XPDUTL(.MSGS)
End DoDot:5
End DoDot:4
+52 IF "^O^H^"[(U_$GET(OH)_U)
SET $PIECE(^ORD(100.05,I,4,X,0),U,6)=OH
SET $PIECE(^ORD(100.05,I,4,X,0),U,7)=""
+53 IF "^1^2^3^"[(U_$GET(SEV)_U)
SET $PIECE(^ORD(100.05,I,4,X,0),U,7)=SEV
SET $PIECE(^ORD(100.05,I,4,X,0),U,8)=""
+54 IF $LENGTH(^ORD(100.05,I,4,X,0),U)=8
SET ^ORD(100.05,I,4,X,0)=$PIECE(^ORD(100.05,I,4,X,0),U,1,7)
End DoDot:3
End DoDot:2
+55 IF $DATA(^ORD(100.05,I,15))
Begin DoDot:2
+56 SET $PIECE(^ORD(100.05,I,11),U,3)=$PIECE(^ORD(100.05,I,15),U,1)
+57 KILL ^ORD(100.05,I,15)
End DoDot:2
+58 SET RECCOUNT=RECCOUNT+1
if '(RECCOUNT#100)
DO UPDATE^XPDID(RECCOUNT)
End DoDot:1
+59 DO UPDATE^XPDID(XPDIDTOT)
+60 DO MES^XPDUTL("DONE")
+61 QUIT
ERROR(TEXT,ERROR) ;OUTPUT FILEMAN ERROR MESSAGE(S)
+1 NEW ORMSG,IDX
+2 SET ORMSG(1)=" "
+3 SET ORMSG(2)="ERROR: "_TEXT_"."
+4 SET ORMSG(3)="VA FileMan Error #"_ERROR("DIERR",1)_":"
+5 FOR IDX=1:1:+$ORDER(ERROR("DIERR",1,"TEXT","A"),-1)
Begin DoDot:1
+6 SET ORMSG(IDX+2)=ERROR("DIERR",1,"TEXT",IDX)
End DoDot:1
+7 DO BMES^XPDUTL(.ORMSG)
+8 QUIT
